perm filename MUS10A.FAI[MUS,LCS]5 blob
sn#435731 filedate 1979-04-21 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00053 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00005 00002 TITLE Music Compiler
C00008 00003 SIZES OF VARIOUS STACKS AND TABLES:
C00011 00004 Bit and Flag Definition
C00017 00005 Macros and Things to Dc
C00020 00006 Initializatize the World (START)
C00023 00007 Setup Input Device
C00025 00008 More SETUP
C00028 00009 Initialization of the Compiler.
C00031 00010 ALGOL SCANNER -- 9/8/66 D. POOLE
C00034 00011 Search Tables
C00037 00012 Scan special Characters
C00040 00013 Scan a string constant
C00044 00014 Number Scanner
C00046 00015 Search Number Table
C00048 00016 Reserved word table search, also SCNGET
C00051 00017 SCAN Storage, also PUSHBUCTBL and POPBUCTBL
C00052 00018 CTBL - The character table
C00056 00019 The Reserved word table
C00062 00020 The Main Symbol Table
C00074 00021 Statement Compilation
C00080 00022 Block Statement (BEGIN...END)
C00082 00023 DONE, EXIT, and RETURN
C00085 00024 PRINT Statement
C00088 00025 IF-THEN-ELSE statement
C00093 00026 IF-THEN-ELSE statement - (R-TIME)
C00096 00027 WHILE statement
C00100 00028 UNTIL statement
C00102 00029 FOR Statement
C00109 00030 Recursive Expression Analyzer.
C00114 00031 Primarys
C00120 00032 Compile a Subscript for Array Reference
C00122 00033 Compile a Function Call.
C00128 00034 Code Generators
C00135 00035 Emit code into code buffers
C00139 00036 GPONDER - Examine top element of operand stack
C00144 00037 Array Reference Generation
C00151 00038 GMURK - Set up top two elements of stack for code generation
C00155 00039 GGET - Gets one of top two stack elements into an AC.
C00159 00040 NUMCHK - Compile time arithmetic
C00163 00041 EMINST - Emit an instruction.
C00166 00042 GETAC - Get a free AC.
C00171 00043 Generate Function Calls
C00175 00044 More Code Generator for Function Calls (GFUNC)
C00182 00045 Unit Generator Call
C00191 00046 Enter Item into Symbol Table
C00194 00047 Declarations
C00197 00048 Function declaration
C00202 00049 More Function Declaration
C00207 00050 Instrument Declaration
C00210 00051 Array Definition
C00214 00052 The Loader
C00218 00053 More Loader (But not much more, you will notice!).
C00222 ENDMK
C⊗;
TITLE Music Compiler
SUBTTL Declarations
$BGMUS:
COMMENT ⊗
* * * * * * * * * * * * * * * N O T I C E * * * * * * * * * * * * * *
If you're going hack it, comment it! (Include your initials in case there's
a bug or incompatability.
******** STANFORD, OCT 1977 --- Leland Smith
******** THIS IS A STRIPPED DOWN VERSION FOR IRCAM-STANFORD.
******** MANY OF THE CONDITIONALS HAVE BEEN REMOVED. THIS VERSION ONLY WRITES
******** ON DSK, AND ALWAYS WITH HEADER BLOCK.
*%*%*%*%*%*%*%* LCS VERSION *%*%*%*%*%*%*%*%*%*
%%%%%% TO LOAD >>>>> LOAD @MUS10 <<<<<<<<
%%%%%% THEN READ IN 'INIT.MUS[MUS,LCS]' FOR ALL INITIALIZATIONS
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
NOTES AND ABRIV.
C.T. ≡ CHARACTER TABLE
U.G. ≡ UNIT GENERATOR
I-TIME ≡ INITIALIZATION TIME FOR INSTRUMENT
R-TIME ≡ RUN TIME FOR INSTRUMENT
⊗;
DEFINE FIX <KIFIX>
IFNDEF KI10SW,< ↓KI10SW←←1 > ;******* SET TO 0 FOR KA10 *******
INTERNAL RDIOSP,WRIOSP,RDINT,RDSIX,WRINT,POP1J.,POP2J.,POP3J.,POP4J.
;USEFUL F4 FUNCTIONS TO HAVE AROUND....
EXTERNAL SIN,COS,EXP,ALOG,SQRT,PLAY,SIND
↓THIS←←2
↓SIZ←←3
↓T←1
↓T1←2
↓T2←3 ; (SAME AS INSXR, SEE BELOW)
↓T3←4 ;DO NOT CHANGE, SEE S.QUOTE
↓A←5
↓B←6
↓C←7
↓D←10
↓E←11
↓F←12 ;USED BY COMPILER TO INDICATE R-TIME CODE
↓H←14
↓OSP←13 ;OPERAND STACK POINTER
↓RA←16 ;RETURN ADDRESS FOR FORTRASH
↓P←17 ;PUSH-DOWN LIST POINTER
↓FL←15
;*** Don't change or else everyone who has external unit generators ***
;*** will haved to be re-assembled ***
NACS←←5
NFACS←←4 ;Number of function AC's
↓INSXR←←NFACS-1
;I/O channel allocation
↓TTY←←1
DT←←2
↓SBCHAN←←4
;SIZES OF VARIOUS STACKS AND TABLES:
↓LOBUFS←←200
LUOTBL←←62 ;LENGTH OF Un LIST
;LPLIST←←100 ;LENGTH OF PUSHDOWN LIST
LPLIST←←200 ;LENGTH OF PUSHDOWN LIST
LOSTK←←40 ;LENGTH OF OPERAND STACK
;LXPLIST←←20 ;LENGTH OF EXTRA PUSHDOWN LIST
LPA←←=50 ;LENGTH OF P_ARRAY
LRQ←←=75 ;LENGTH OF RUN QUEUE.
OPDEF REWIND[MTAPE 1];***MTA←1; WRITES ON MTA0. ←-1 SAME BUT DOES REWINDS.
OPDEF EXP [0]
OPDEF INTJEN [723B8]
OPDEF JRSTF [JRST 2,]
IFE KI10SW,< OPDEF FIX[XWD 247000,0] > ;**** FOR KA10 FIX *****
↓UUOTAB←.-1 ;HERE ARE OUR USER UUO'S
↓UUOMAX←0
DEFINE DEFUUO $(NAME)
< ↓UUOMAX←←UUOMAX+1
OPDEF NAME [UUOMAX*1000000000]
.$NAME
>
;*** Don't change (adding OK) or else everyone who has external unit ***
;*** generators will have to re-assembled ***
IFN UUOMAX,
< PRINTS/
Warning: You won't be able to use EXTERNAL UNIT_GENERATOR which call error
routines!!!
/>;IFN UUOMAX
DEFUUO ERRUUO ;Error call (Must be 001000,,0)
DEFUUO TYPCHR ;TYPE A CHARACTER (LIKE OUTCHR)
DEFUUO TYPSTR ;TYPE A STRING (LIKE OUTSTR)
OPDEF HALT [HALT] ;SO THAT DDT KNOWS ABOUT THE FOLLOWING
OPDEF TTYUUO[XWD 51000,0]
OPDEF INCHRW[TTYUUO 0,]
OPDEF OUTCHR[TTYUUO 1,]
OPDEF OUTSTR[TTYUUO 3,]
OPDEF INCHWL[TTYUUO 4,]
;;OPDEF GETLIN[TTYUUO 6,]
OPDEF RESET [CALLI 0]
OPDEF CORE [CALLI 11]
OPDEF EXIT [CALLI 12]
OPDEF DATE [CALLI 14]
OPDEF MSTIME[CALLI 23]
;;OPDEF GETPPN[CALLI 24]
OPDEF RUNTIM[CALLI 27]
OPDEF SETNAM[CALLI 43] ;DEC SYSTEMS USE A DIFFERENT OPCODE
SUBTTL Bit and Flag Definition
;Character Table bits
MULBIT←←1 ;C.T. '*` OR '/`
ADDBIT←←2 ;C.T. '+` OR '-`
STRFLG←←4 ;DO NOT CHANGE, SEE S.QUOTE
SSPCF ←←10 ;C.T. FLAG
SDFLG ←←20 ;C.T. FLAG
SNUMF ←←40 ;C.T. FLAG
FOOBIT←←100 ;FOO SYMBOL (EITHER P<number> or U<number>)???
FIXFLG←←1000 ;NUMBER TABLE ENTRIES
FLTFLG←←2000
SSPC2F←←4000 ;CHARACTER TABLE ENTRY
RELBIT←←10000 ;RELATIONAL OPERATOR
LOGBIT←←20000 ;C.T. '∧` OR '∨`
DF ←←400000 ;DELIMITER
NUMFLG←←FIXFLG+FLTFLG
;Symbol Table bits
RFLG ←←0 ;$$$%%&%$###""##$%$$$$$
RSTMTB←←20 ;(SYMBOL TABLE) STATEMENT RESERVED WORD
INSBIT←←40 ;INSTRUMENT NAME
GPBIT ←←FOOBIT ;NOT I OR X. (FOO SYMBOL P<number>)
FPARBT←←200 ;FORMAL PARAMETER
DECLBI←←400 ;DECLARACTORY RESERVED WORD
RVBT ←←400 ;R-TIME VARIABLE
PRVBT ←←11 ;SHIFT CONSTANT FOR 'RVBT`
;1000 ;INTEGER
;2000 ;REAL
UGBIT ←←4000 ;U.G. NAME
SRACBT←←10000 ;(STACK) R-TIME AC
SIACBT←←20000 ;(STACK) I-TIME AC
FUNBIT←←40000 ;(IN SYMBOL TABLE) FUNCTION NAME
SUBSBT←←FUNBIT ;(STACK) SUBSRIPT FOR ARRAY
SWVBT ←←100000 ;ARRAY NAME??? (DO NOT CHANGE ! SEE GFUNC.)
ARRYBT←←SWVBT ;NOTE THAT NOT ALL CODE HAS BEEN CONVERTED TO
;USE THIS YET
VRBLBT←←200000 ;VARIABLE
RF ←←DF+RFLG ;RESERVED WORD
; RELOCATION AND FIXUP BITS
.FXBTS←←1
LFXBTS←←2
RRELBT←←4+1 ;R-TIME RELOCATION (LEFT HALF)
IRELBT←←10+1 ;I-TIME RELOCATION (RIGHT HALF)
VRELBT←←14+1 ;VARIABLE RELOCATION (RIGHT HALF)
CHAINB←←20000 ;A CHAIN FIXUP
SWAPBT←←40000 ;SWAPPED FIXUP.
RRFXBT←←100000 ;RIGHT HALF.
LRFXBT←←200000 ;LEFT HALF REPLACEMENT FIXUP BIT.
TWOWRD←←400000 ;TWO WORD FIXUP
; FLAGS (RIGHT HALF):
CSBRBT←←1 ;INSIDE FUNCTION DEFINITION
USBRBT←←2
GFUNCF←←4
SFOOBT←←10 ;LETS SCANNER SEE FOO SYMBOLS
ARRFLG←←20
EXTFLG←←40 ;SET DURING EXTERNAL FUNCTION DEFINITION
RVFLG ←←100
RESTART←←200 ;RESTART FLAG FOR SETUP
INSDEF←←1000 ;INSTRUMENT DEFINITION
; FLAGS (LEFT HALF).
ERRFLG←←1
MINFLG←←2
SNUMF1←←4
NOSTAR←←10 ;DON'T PRINT PRINT PROMPT
DTFLG←←20
PLAYFLG←←40
; AC TABLE FLAGS
ACFLAG ←←SIACBT+SRACBT
;SUBSBT←←40000 ;A SUBSCRIPT (KEEP IN AC)
;SWVBT ←←100000 ;AN ARRAY (SHOULDN'T BE THERE THOUGH)
;VRBLBT←←200000 ;A VARIABLE
NOSWAP ←←400000 ;DON'T SWAP OUT OF AC
; PARAMETER DESCRIPTOR BITS:
;*** Don't change (adding OK) or else everyone who has external unit ***
;*** generators will have to re-assembled ***
↓ARRPAR←←1 ;ARRAY PARAMETER
↓VARPAR←←2 ;REAL PARAMETER
↓ZTMPPAR←←4 ;ZEROED TEMPORARY
↓TMPPAR←←5 ;TEMPORARY
↓STRPAR←←6 ;STRING PARAMETER
↓INTPAR←←11 ;INTEGER PARAMETER
↓STAPAR←←12 ;ARRAY OR STRING PARAMETER
BITABL: ;There is a feature in our debugger to print bit symbols
RADIX50 0,DF ;400000 ;DELIMITER
RADIX50 0,VRBLBT ;200000 ;VARIABLE
RADIX50 0,SWVBT ;100000 ;ARRAY NAME???
RADIX50 0,FUNBIT ;40000 ;(IN SYMBOL TABLE) FUNCTION NAME
RADIX50 0,SIACBT ;20000 ;(STACK) I-TIME AC
RADIX50 0,SRACBT ;10000 ;(STACK) R-TIME AC
RADIX50 0,UGBIT ;4000 ;U.G. NAME
RADIX50 0,FLTFLG ;2000
RADIX50 0,FIXFLG ;1000 ;NUMBER TABLE ENTRIES
RADIX50 0,DECLBI ;400 ;DECLARACTORY RESERVED WORD
RADIX50 0,FPARBT ;200 ;FORMAL PARAMETER
RADIX50 0,FOOBIT ;100 ;FOO SYMBOL
RADIX50 0,INSBIT ;40 ;INSTRUMENT NAME
RADIX50 0,RSTMTB ;20 ;(SYMBOL TABLE) STATEMENT RESERVED WORD
RADIX50 0,SSPCF ;10 ;C.T. FLAG
RADIX50 0,STRFLG ;4 ;Strings
RADIX50 0,ADDBIT ;2 ;C.T. '+` OR '-`
RADIX50 0,MULBIT ;1 ;C.T. '*` OR '/`
BLOCK =18
SUBTTL Macros and Things to Dc
COMMENT ⊗ THINGS TO DO
MAKE NEW PARAMETER DESCRIPTOR
Change PUSHJ P,ILLARF to something less dangerous!!!
Fix SETDATE in SMPOUT to know about DATE75
⊗;
DEFINE ILG
< XWD DF+SSPCF,SILCH
> ;ILLEGAL CHARACTER MARKER FOR SYMBOL TABLE
; ERROR AND DEBUGGING MACROS
DEFINE ERROR (M) ;FATAL ERROR
< ERRUUO 1,[ASCIZ /M/]
>
DEFINE WARN (M) ;WARNING
< ERRUUO 2,[ASCIZ /M/]
>
DEFINE SKWARN (M) ;WARNING, SKIPS IF NOT A WARNING
< ERRUUO 3,[ASCIZ /M/]
CAIA
>
DEFINE WARNSK (M) ;WARNING, SKIPS AFTER CONTINUE
< ERRUUO 3,[ASCIZ /M/]
>
;USED WHEN SOMETHING HAPPENS THAT SHOULDN'T LIKE NOT BEING ABLE TO INIT DSK
DEFINE SYSERR (M)
< ERRUUO 4,[ASCIZ /M/]
>
DEFINE DEBUG (M)
< SKIPE DEBUGF
ERRUUO 10,[ASCIZ/M/]
>
DEFINE DEBUG2 (M) ;THIS FLAVOR STOPS IF IN MODE 4
< SKIPE DEBUGF
ERRUUO 11,[ASCIZ/M/]
>
DEFINE COREFULL ;WE RAN OUT OF CORE, LET TRY TO GET SOME MORE
< PUSHJ P,.CORFL ;SKIP IF NOT CALLED
SKIPA
>
;CONCATONATE TWO SYMBOLS
DEFINE CAT &(SYM1,SYM2)
<SYM1&SYM2>
;Macro to handle the two flavours of FIX instructions/UUOs
;outside of Stanford. This mess is because there wasnit enough
;space left in the KL10 microcode space and the FIX instruction
;which was on the KA10 was not implemented in the KL10. Because
;of this, FAIL at Stanford had the opcode for FIX changed to
;KAFIX and the opcode for the KI10 FIX instruction (which is an
;inferior instruction) introduced as KIFIX.
CONFIG:
ASCIZ/Stanford Music Compiler -- LCS Version /
PRINTS/Stanford Music Compiler -- LCS Version
/
SUBTTL Initializatize the World (START)
START:
GO: MOVE P,PDLIOWD
;Distinguish between KA10 and KL10
SETZ 0, ;BLT works different on KL10 from KA10
BLT 0,0 ;On KL10, will set 0 to 1,,1 and then
;copy itself to itself. On KA10, it
;will copy 0 to 0
JUMPE 0,[OUTSTR[ASCIZ/?
This program only runs on the KL10. Sorry.
(Please type 'R NEWMUS' instead)/]
EXIT]
KALUSER:
AOSLE ONCEFG ;IS THIS FIRST TIME THROUGH ?
JRST GOA ;NO. LEAVE JOBFF AT CURRENT PLACE.
OUTSTR CONFIG ;Print version number
GO1: MOVEI 0,GOB ;SET REEENTER ADR.
MOVEM JOBREN↑
HLRO 1,JOBSYM↑ ;YES. GET BEGINNING OF SYM. TAB. FROM JOBSYM
MOVNS 1
ADD 1,JOBSYM ;ADD LENGTH OF SYM. TAB.
HLRZ 0,JOBSA↑
CAIL 0,(1)
MOVE 1,0
AOSN ONCEFG ;WAS THIS A FROZEN COPY?
HRRZM 1,JOBFF ;NO, RESET JOBFF *****
MOVE JOBFF
MOVEM OLDJFF# ;SAVE PRESENT JOBFF
MOVE [XWD SVAREA,BUCTBL]
BLT SVAREA-1
GOA: HRRZ JOBFF ;*****
HRLM JOBSA
MOVEI FL,0
PUSHJ P,SETUP
GOB: MOVE P,PDLIOWD
REPEAT 0,< ;Moved to after SCHOWN
MOVE JOBREL
MOVEM BEGFREE ;*****
SUB JOBFF
SKIPN GETMORE# ;DO WE NEED TO GET MORE?
CAIGE =2048 ;NO, DO WE HAVE AT LEAST 2K WORDS OF CORE?
COREFULL ;COREFULL WILL KINDLY GET US SOME MORE
SETZM GETMORE ;CLEAR CORE REQUEST FLAG
>;REPEAT 0
JRST SCHOWN ;YES, RETURN
ONCEFG: -2 ;-1 FOR FROZEN COPIES
DEBUGF: 0
LSTFUL: 0
SUBTTL Setup Input Device
;INPUT ROUTINE. CALL INITIALLY WITH PUSHJ P,SETUP
;WILL READIN DTA# AND FILE NAME. GET CHRS BY
;ILDB IBUF+1. NEXT BUFFER BY INPUT DT,0.
SETUP: RESET
MOVE [JSR UUOSER]
MOVEM 41 ;SET UP UUO TRAP
SETZM INERR
SETZM INUUO
SETUP1: INIT TTY,1
SIXBIT /TTY/
XWD TOB,TIB
SYSERR <Can't INIT TTY!>
COMMENT ⊗ An unlikely situation. ⊗;
MOVSI 400000
ANDCAM TIBUF+1 ;MARK INPUT BUFFERS EMPTY.
ANDCAM BUF1+1
ANDCAM BUF2+1
ANDCAM BUF3+1
HRRI TIBUF+1 ;INIT. BUFFER POINTERS.
MOVEM TIB
HRRI TOBUF+1
MOVEM TOB
OUTPUT TTY, ;SEE THE HAPPY SYSTEM
TRNE FL,RESTART ;ARE WE RESTARTINIG ?
JRST SETUP2 ; Yes
OUTSTR [ASCIZ /
INPUT ? /]
PUSH P,[DNAM]
PUSH P,[INCHWL 1]
PUSH P,[0]
PUSHJ P,RDIOSP
JRST [ MOVSI 1,'TTY'
MOVEM 1,DNAM
JRST .+1 ]
PUSHJ P,IGNOLF
JRST SETUP2
BUF1: 0
XWD 201,BUF2+1
BLOCK 202
BUF2: 0
XWD 201,BUF3+1
BLOCK 202
BUF3: 0
XWD 201,BUF1+1
BLOCK 202
; More SETUP
TIB: 0
POINT 7,0,35
0
TOB: 0
POINT 7,0,35
0
TIBUF: 0
XWD 21,.
BLOCK 22
TOBUF: 0
XWD 21,.
BLOCK 22
1 ;MODE
DNAM: 0
XWD 0,IBUF
DLK: BLOCK 5
RECCT: 0
IBUF: XWD 400000,BUF1+1; MAGIC TO KEEP SYSTEM
SCP: POINT 7,0,35; HAPPY
ICCNT: 0 ;BUFFER CHAR. COUNT.
SETUP2: OPEN DT,DNAM-1
JRST AER1
MOVE [XWD 400000,BUF1+1] ;SET UP BUFFER
MOVEM IBUF ;HEADER SO SYSTEM WILL USE OUR BUFFERS.
MOVSI 700
MOVEM SCP ;BYTE SIZE.
TRZE FL,RESTART ;ARE WE RETARTING
JRST SETIN ;YES, SKIP REST
MOVEI T,1 ;SET INFO FOR EDITTING
MOVEM T,LINCNT
MOVEM T,PAGCNT
SETZM LINENO
MOVEM T,RECCT
;;;SETIN: MOVE T,DLK+3 ;SAVE P,PN OVER LOOKUP
SETIN: SETZM DLK+3 ; ZERO PPN
LOOKUP DT,DLK
JRST [ MOVSI 'MUS' ;Assume 'MUS' as default extension
EXCH DLK+1
TLNN -1 ;Make sure extension was't given
LOOKUP DT,DLK
JRST NER1 ;NON-EX FILE
JRST .+1 ]
;;; MOVEM T,DLK+3 ;RESTORE P,PN
PUSHJ P,RDBUF ;GET FIRST BUFFER
MOVE BUF1+3 ;LINE NO. FIRST ?
TRNE 1
AOS SCP ;YES; ADVANCE SCP PAST IT.
SETZM SNCHR
SETZM FOONLY# ;BARF !!
POPJ P,; DONE
; Error routines for SETUP
AER1: TYPSTR [ASCIZ /
Device: /] ;ERROR ROUTINE FOR DEVICE NOT AVAILABLE
MOVEI T1,4
MOVEI DNAM
PUSHJ P,SIXOUT
TYPSTR [ASCIZ / not available.
/]
JRST SETUP
NER1: EXCH 0,DLK+1 ;Get back old extension
NER: TYPSTR [ASCIZ /
File: /] ;ERROR ROUTINE FOR FILE NOT FOUND
PUSH P,[DLK]
PUSHJ P,PRTFLN
NEX1: TYPSTR [ASCIZ / not found.
/]
JRST SETUP
SUBTTL Initialization of the Compiler.
EXTERNAL JOBFF,JOBSA
BEGFREE: 0 ;POINTER TO BEGINNING OF FREE STORAGE AREA
SCOMPA: MOVE OSP,[IOWD LOSTK,OSTK] ;INIT. OPERAND STACK.
PUSH OSP,BEGFREE ;...SO WE CAN RESTORE IT LATER.
MOVSI IRELBT ;INIT THE THREE LOCATION
MOVEM ILOC ;COUNTERS (APPROPRIATE RELOCATION
MOVSI RRELBT ;BITS LIVE IN LEFT HALF OF EACH).
MOVEM RLOC
MOVSI VRELBT
MOVEM VLOC
MOVEI T1,2 ;SET UP THE THREE CHAINS OF OUTPUT
SCMP1: SETZM OBPTR(T1)
PUSHJ P,GBUF ;BUFFERS.
HRRZM T,FCBUF(T1) ;PTR. TO FIRST BUFFER OF CHAIN
SOJGE T1,SCMP1 ;DO FOR ALL THREE CHAINS.
SETZM IARR1 ;ZERO SOME TABLES AND STUFF.
MOVE [XWD IARR1,IARR1+1]
BLT IARR2-1
SETOM IARR1 ;SET THESE TO -1
MOVE [XWD IARR2,IARR2+1]
BLT IARR5-1
MOVEI FL,0 ;CLEAR FLAGS.
POPJ P,
SCOMP: PUSHJ P,SCOMPA ;INIT. THE COMPILER.
SETZM IARR4
MOVE [XWD IARR4,IARR4+1]
BLT IARR3-1 ;ZERO REST OF TABLES.
POPJ P,
;DONE WITH COMPILATION, CLEAN UP YE OLE COMPILER
ENDP1:
SKIPE BLEVEL ;ARE ALL BLOCKS CLOSED
WARN <Missing END> ;NO!
COMMENT ⊗ FINISH statement giving inside a block. ⊗;
MOVEI A,0
MOVEI B,.FXBTS ;PUT END MARKS IN THE BUFFERS.
PUSHJ P,EMCD
PUSHJ P,EMICD
PUSHJ P,EMVCD
; POP OSP,BEGFREE ;RESTORE BEGFREE.
;WHY DID YOU RELEASE FREE STORAGE BEFORE YOU WERE DONE WITH, D.POOLE?!!?
POPJ P,
SUBTTL ALGOL SCANNER -- 9/8/66 D. POOLE
;CALL IS PUSHJ P,-----. SCANS NEXT ATOMIC ELEMENT OF
; INPUT STRING, RETURNS ELEMENT IN ACCUM. 'A' AS FOLLOWS:
; UNDEFINED IDENTIFIER-- RETURNS 0.
; DECLARED IDENTIFIER--- 'A' CONTAINS RANDOM GOOD BITS FROM
; THE SYM. TBL. IN LEFT HALF, PTR. TO RGB WORD IN RT. HALF.
;RESERVED WORD OR SINGLE-CHARACTER OPERATOR--- 'A' CONTAINS
; THE RANDOM BITS WORD FROM EITHER THE RESERVED WORD TABLE
; OR THE CHAR. CONVERT TABLE, RESPECTIVELY.
BEGIN SCAN
↑BUCKNO←←1; SEE DFUNC BEFORE CHANGING !!!!
↑ACCUM: BLOCK 40 ;GOOD ENOUGH FOR NOW...
ACCEND←←.
↑SCANNS: TLOA FL,NOSTAR ;SUPRESS PRINTING OF *.
↑SCANR: TLOA FL,400000 ;ENTRY WHEN EXPECTING OPERATOR OR
; RESERVED WORD.
↑SCANV: TLZ FL,400000 ;ENTRY WHEN EXPECTING VARIABLE.
↑SCAN:
SKIPE A,SNCHR ;IF SNCHR IS NON-ZERO,
JRST SL1 ; IT IS THE NEXT CHAR. TO SCAN.
SL10: ILDB A,SCP ;GET NEXT CHAR.
SKIPN A,CTBL(A) ;SKIP LEADING BLANKS.
JRST SL10
JUMPL A,SL1B ;IF OPERATOR, WE'RE DONE.
TLNE A,SNUMF ;CHECK FOR PART OF A NUMBER.
JRST SNUM1
MOVE T2,[POINT 6,ACCUM,5] ;PREPARE TO SCAN AN
SETZB T,ACCUM ;IDENTIFIER.
MOVEM T,ACCUM+1
MOVEM A,FOONLY
SL2: IDPB A,T2 ;APPEND CHAR. TO IDENTIFIER.
SL2A: ILDB A,SCP ;NEXT CHAR.
SKIPLE A,CTBL(A) ;CHECK FOR TERMINATOR.
AOJA T,SL2 ;INCREMENT COUNT AND LOOP.
TLNE A,SSPC2F ;DOES TERMINATING CHAR. REQUIRE IMMEDIATE
;ATTENTION?
JRST [ PUSHJ P,(A) ;YES!
JRST SL2A]
MOVEM A,SNCHR ;NO, SAVE IT FOR NEXT TIME.
ADDI T,1
DPB T,[POINT 6,ACCUM,5] ;PUT COUNT IN FIRST CHAR.
SETZ A,
TLNN T2,770000 ;HAVE WE FILLED THE LAST CHARACTER IN WORD?
JRST .+3 ;YES
IDPB A,T2 ;NO, PUT IN A 0
JRST .-3 ;TRY AGAIN
HRRZS T2
SUBI T2,ACCUM
HRRZM T2,ACCWC#
; Search Tables
MOVE A,ACCUM ;PREPARE TO SEARCH TABLES.
MOVE C,ACCUM+1
TLZE FL,400000 ;DO WE EXPECT AN OPERATOR ?
JRST SRSCH ;YES; SEARCH RES. WD. TBL. FIRST
SMSCH: MOVE T,A ;SEARCH MAIN SYM. TBL.
IDIVI T,BUCKNO ;DO HASH ON IDENT.
MOVMS T1 ;MAKE SURE IT'S POSITIVE.
MOVEM T1,CBNO ;SAVE BUCKET NO.
HRRZ B,BUCTBL(T1) ;HEAD OF RIGHT BUCKET IN SYM. TBL.
SL5: CAMN A,1(B) ;COMPARE FIRST WORDS.
JRST SL4
SL6: HRRZ B,(B) ;GET NEXT ELEMENT OF
JRST SL5 ; THE LINKED LIST.
SL4: CAIN B,A-1 ;FIRST WORD WAS EQUAL...
JRST SNO ; WE ARE AT END OF BUCKET.
SKIPN T1,T2
JRST SFOUND ;ONLY 1 WORD; WE'RE DONE.
CAME C,3(B) ;COMPARE SECOND WORDS...
JRST SL6 ;NOPE.
SOJE T1,SFOUND ;ANY MORE WORDS ?
MOVE T3,[XWD B,4]; YES. PREPARE TO CHECK THEM.
SL7: MOVE D,ACCUM-2(T3)
CAME D,@T3
JRST SL6 ;NOT EQUAL.
SOJE T1,SFOUND ;MORE STILL ?
AOJA T3,SL7 ;YES; KEEP CHECKING.
SFOUND: MOVEI A,2(B) ;FOUND HIM; CALC. PTR. TO RGB WORD.
HLL A,(A) ;GET RANDOM GOOD BITS.
HRRZ B,A
SEXIT: CAIG T2,1 ;MORE THAN 2 WORDS OF NAME ?
POPJ P, ;NO.
SETZM ACCUM(T2) ;YES; ZERO OUT ALL THE WORDS OF
SOJA T2,SEXIT ; ACCUM THAT WE USED.
SNO: TLCN FL,400000 ;NOT IN MAIN TBL; HAVE WE ALREADY
JRST SRSCH ; SEARCHED RES. WORD TBL ?
SN1: MOVE A,FOONLY ;GARPBAZ !
TLNE A,FOOBIT
JRST FOOSCH
SCH1: SETZB A,B ;YES. RETURN 'UNDEFINED'.
POPJ P,
SL1: SETZM SNCHR ;RETURN FOR A SPECIAL CHAR.
SL1A: TLNE A,SSPC2F ;DID IT REQUIRE IMMEDIATE SERVICE?
PUSHJ P,DRYROT ;IT DIDN'T GET IT!!
SL1B: TLNN A,SSPCF+SSPC2F ;DOES IT NEED SPECIAL ATTENTION?
POPJ P,
PUSHJ P,(A) ;YES. DISPATCH ON IT.
JRST SL10 ;CONTINUE SCANNING.
; Scan special Characters
FOOSCH: LDB B,[POINT 6,ACCUM,17]
TRNE FL,SFOOBT ;ARE WE DEFINING A FUNCTION ?
JRST SCH1 ;YES. NO FOO-SYMBOLS ALLOWED.
CAIG B,31 ;IS IT A DIGIT?
CAIGE B,20
JRST SCH1 ;NO.
SUBI B,20 ; TO VALUE.
LDB C,[POINT 6,ACCUM,23]
JUMPE C,FSCH1
LDB D,[POINT 6,ACCUM,29]
JUMPN D,SCH1
IMULI B,12 ;MUL. TENS DIGIT BY 10.
CAIG C,31
CAIGE C,20
JRST SCH1
ADDI B,-20(C) ;ADD IN ONE'S DIGIT.
FSCH1: DPB B,[POINT 17,A,35] ;PUT NUMBER IN A.
POPJ P, ;RETURN FROM SCAN.
↑S.NULL: JRST SENDL
↑S.FF: SETZM LINCNT ;FORM FEED, RESET LINE COUNT AND INCREMENT PAGE COUNT
AOS PAGCNT
↑S.LF: AOS LINCNT ;LINE FEED, INCREMENT LINE COUNT
MOVE A,NXTPAG
JUMPE A,S.VT ;FAST EXIT FOR NO DEBUG MODE
CAMLE A,PAGCNT ;ARE WE AT THE RIGHT PAGE?
JRST S.VT ;NO
MOVE A,NXTLIN
JUMPE A,S.VT ;FAST EXIT FOR NO DEBUG MODE
CAMLE A,LINCNT ;ARE WE UP TO RIGHT LINE
JRST S.VT ;NO
SETZM NXTPAG
SETZM NXTLIN
MOVEI A,2 ;SET DEBUGFLAG TO 2 (STOP EVERYTIME)
MOVEM A,DEBUGF
DEBUG <AT OR PAST REQUESTED LINE>
↑S.VT: ;VERTICAL TAB.
↑SENDL: PUSH P,T ;SAVE T AS IT IS NEEDED
TLZ FL,ERRFLG ;END OF LINE. CLEAR ERROR FLAG.
MOVE A,SCP ;GET PTR TO WORD.
SKIPN T,(A) ;CHECK THIS WORD
JRST S.EOB ;ZERO WORD MEANS END OF BUFFER.
ADDI A,1
MOVE T,(A)
TRNN T,1 ;IS IT A LINE NO. ?
JRST POPTJ ;NO; CONTINUE SCANNING.
MOVEM T,LINENO
TLZ A,770000 ;YES; ADVANCE PTR. PAST IT.
MOVEM A,SCP
↑POPTJ: POP P,T ;RESTORE T
POPJ P, ;RETURN
↑S.EOB: PUSHJ P,RDBUF ;REFILL BUFFER.
JRST SENDL+1
SSPCB: ;HALT
SSPCC: ;HALT
PUSHJ P,DRYROT
↑S.LT: SKIPE LOGFLG ;DO WE SEE '<` AS COMMENTER?
JRST [ MOVE A,[XWD DF+RELBIT,LOP];NO, GET REAL CONTENT
POP P,(P) ;THROW TOP OF P
POPJ P,] ;RETURN
MOVE B,LFV
PUSHJ P,.COMM2
JRST S.LF
;Scan a colon and check for ':='
↑S.COLN:popj p,
; Scan a string constant
;
↑S.QUOT: SETZM SNCHR ;IS THIS NECESSARY?
MOVE T2,[POINT 7,ACCUM] ;GET A BYTE POINTER FOR STRING
MOVSI T,-5*(ACCEND-ACCUM) ;AND HOW MANY CHARACTERS WE CAN FIT
S.QUO2: ILDB A,SCP ;GET A CHARACTER
CAIN A,42 ;IS IT AN END OF STRING (A SECOND '"`)
JRST S.QUO4 ;YES
JUMPE A,S.QUO3 ;DON'T PUT NULL INTO STRINGS!!!
CAIN A,"≡" ;IS IT A MAGIC QUOTE CHARACTER?
ILDB A,SCP ;YES, GET ANY CHARACTER
AOBJP T,[ERROR <String too long or missing ">]
COMMENT ⊗ Strings have a limited length. ⊗;
IDPB A,T2 ;PUT IT INTO ACCUM
CAIE A,"<" ;%$%$%%&#! DON'T GET ITS CHARACTER TABLE ENTRY
S.QUO3: MOVE A,CTBL(A) ;GET IT'S TABLE ENTRY
TLNE A,SSPCF+SSPC2F ;DOES IT REQUIRE SERVICE
CAMN A,[ILG] ;BUT ISN'T ILLEGAL CHARACTER
JRST S.QUO2 ;NO, GO GET ANOTHER
PUSHJ P,(A) ;DISPATCH ON ANYTHING ELSE
JRST S.QUO2 ;GO GET ANOTHER
S.QUO4: SETZ A, ;CLOSING QUOTE FOUND
AOBJP T,[ERROR <String too long or missing ">]
COMMENT ⊗ Strings have a limited length. ⊗;
IDPB A,T2 ;MAKE SURE THERE IS AT LEAST ONE NULL BYTE
TLNE T2,760000 ;IS THE WORD FILLED WITH ZEROS YET?
JRST .-3 ;NO
SUBI T2,ACCUM ;CALCULATE WORD COUNT
ADDI T2,1
HRRZM T2,ACCWC ;SAVE WORD COUNT
MOVE T3,(P) ;PUT IT SOMEWHERE SAFE (WE DON'T NEED OUR
;RETURN ADDRESS ANYMORE ANYWAY)
MOVE A,[XWD STRFLG,STRBUC+1] ;GET FIRST NODE
;**** NOTE THAT STRFLG=T3 AND IS USED AS AN INDEX
;REGISTER DURING STRING COMPARE!
STRSRH: HRR A,-1(A) ;LOOK AT NEXT NODE
TRNN A,777760 ;AT END?
JRST STRNFD ;YES, STRING NOT FOUND, ENTER IT
SETZ T3, ;LET'S SEE IF IT'S WHAT WE'RE LOOKING FOR
STRSR2: MOVE T,ACCUM(T3)
CAME T,@A ;'A` CONTAINS <node address>(T3)
JRST STRSRH ;NOP, TRY THE NEXT NODE
TRNE T,376 ;IS IT THE END OF THE STRING?
AOJA T3,STRSR2 ;NO, LOOK AT THE NEXT WORD
JRST STRFIN
STRNFD: MOVE T,ACCWC ;GET SIZE OF STRING
ADDI T,1 ;FOR THE LINK
PUSHJ P,GPS ;GET SOMEWHERE TO PUT IT
AOS T2,T
HRLI T2,ACCUM ;MAKE A BLT POINTER
HRR A,T ;TO RETURN FROM SCAN
ADD T,ACCWC ;AND FIND OUT ADDRESS OF LAST WORD
; BLT T2,(T) ;COPY IT (gee! that never should have worked)
BLT T2,-1(T) ;COPY IT
HRRZ T2,A
EXCH T2,STRBUC ;GET LAST POINTER AND MAKE THIS NEW POINTER
MOVEM T2,-1(A) ;PUT INTO LINK
STRFIN: POP P,T3 ;RESTORE T3
POPJ P, ;AND WE'RE DONE
; Number Scanner
SNUM1: MOVEI C,0 ;NUMBER SCANNER.
CAMN A,DOTV ;FIRST THING A DECIMAL PT.?
JRST SNUM6 ;YES
MOVNI T,100 ;NO DEC PT. YET.
SNUM2: IMULI C,12
ADDI C,-20(A) ;CONVERT NEW DIGIT TO VALUE AND ADD IN
AOSA T ;INCREMENT DEC. PLACE COUNT.
SNUM6: MOVEI T,0 ;START COUNTING DEC. PLACES.
ILDB A,SCP ;NEXT CHAR.
SKIPG A,CTBL(A) ;GET MAGIC BITS.
JRST SNUM7 ;IT'S A DELIMITER.
TLNE A,SDFLG ;IS IT A DIGIT ?
JRST SNUM2 ;YES.
CAMN A,DOTV ;A DEC. PT. ?
JRST SNUM6 ;YES.
JRST SNUMX1
SNUM7: TLNE A,SSPC2F ;DOES DELIM. REQUIRE INSTANT SERVICE ?
JRST [ PUSHJ P,(A) ;SERVICE IT AND TRY AGAIN
JRST SNUM6+1]
MOVEM A,SNCHR ;SAVE FOR NEXT TIME.
; JUMPLE T,SNFX ;IF NO DEC. PT. SEEN, IT'S FIXED PT.
SFLTIT: IDIVI C,400000 ;FLOAT IT.
SKIPE C
TLC C,254000
TLC D,233000
FAD C,D
SKIPLE T
FDVR C,[10.0] ;DIVIDE BY 10 ENOUGH TO GET
SOJG T,.-1 ;DEC. PT. IN RIGHT PLACE.
SKIPA T,[XWD FLTFLG,0] ;GET FLOATING PT. FLAG.
SNFX: MOVSI T,FIXFLG
HLLZ A,T ;COPY FLAG TO A.
TRNN FL,SFOOBT
TLZE FL,SNUMF1 ;SKIP IF WE'RE SAVING NUMBERS TODAY
POPJ P,
; Search Number Table
↑SRHNUM: TDOA A,NUMBUC ;NUMBUC TO RT. HALF.
SNUM4: HRR A,-1(A) ;GET NEXT LINK.
CAME C,(A) ;IS IT EQUAL ?
JRST .-2 ;NO.
TRNN A,777760 ;ARE WE AT END OF TABLE ?
JRST SNUMNO ;YES.
TDNN T,-1(A) ;NO. DO TYPES MATCH ?
JRST SNUM4 ;NO.
POPJ P, ;YUP. WE'VE FOUND IT.
SNUMNO: ;TRNE FL,CSBRBT ;ARE WE INSIDE A FUNCTION DEFINITION ?
; JRST SNUMX ;YES.
;WHY IS IT NECESSARY TO TREAT FUNCTION DEFINTIONS SPECIAL???!!?
MOVEI T,2 ;INSERT NUMBER INTO TABLE
PUSHJ P,GPS ;GET SOME PERMANENT STORAGE
AOS T
HRR A,T
EXCH T,NUMBUC ;UPDATE NUMBUC.
HRRM T,-1(A) ;PUT IN NEW LINK.
HLLM A,-1(A) ;PUT IN TYPE FLAG.
MOVEM C,(A) ;ALSO VALUE.
POPJ P,
COMMENT ⊗ DISCONNECTED!
SNUMX: IOR T,VLOC ;WE WILL PUT NO. IN VARIABLES AREA.
PUSH P,T ;SAVE PTR. TO LOC.
MOVE A,C ;VALUE OF NO. TO A.
MOVEI B,0 ;NO RELOCATION.
PUSHJ P,EMVCDI ;EMIT TO VARIABLES BUFFER.
JRST POPAJ ;SEE EMINST.
⊗;
; Reserved word table search, also SCNGET
SRSCH: LDB B,[POINT 6,ACCUM,5] ;GET CHAR. COUNT.
CAIL B,2 ;NO 1-CHAR. RES. WDS.
CAILE B,MAXRSZ ;ALSO NONE OF > 9 CHARS.
JRST SRNO
MOVE B,SRTBL1-2(B) ;GET RIGHT SECTION OF TBL.
CAME A,(B) ;COMPARE FIRST WORD.
SRS1: AOBJN B,.-1
JUMPGE B,SRNO ;ARE WE AT END OF SECTION ?
CAME C,LRTBL(B) ;NO; COMPARE SECOND WORD.
JRST SRS1
MOVE A,GRTBL(B) ;THIS IS IT; GET GOOD BITS.
TLNE A,SSPCF ;DOES IT NEED OUR ATTENTION ?
JRST (A) ;YES.
JRST SEXIT ;NO.
SRNO: TLCN FL,400000 ;NOT A RES. WORD; HAVE WE ALREADY
JRST SMSCH ;SEARCHED MAIN SYM. TBL. ?
JRST SN1 ; YES; RETURN.
↑.COMME: MOVE A,SNCHR ;A COMMENT; SKIP TO NEXT ';'
SETZM SNCHR
MOVE B,SEMICV
PUSHJ P,.COMM1
JRST SCAN
.COMM1: CAMN A,B ;DID WE FIND THE CHARACTER WE WERE LOOKING FOR?
POPJ P, ;YES, RETURN
CAME A,[ILG] ;IGNORE ILLEGAL CHARACTERS
CAMN A,QUOTEV ;DON'T PARSE STRINGS!!!!!
JRST .COMM2
CAMN A,LTV ;DON'T ACT ON '<'
JRST .COMM2
TLNE A,SSPCF+SSPC2F ;SPECIAL TREATMENT ?
PUSHJ P,(A) ;YES.
.COMM2: ILDB A,SCP
MOVE A,CTBL(A)
JRST .COMM1
;Character stream for scan
↑SCNGET:PUSH P,A ;SAVE A
ILDB 1,SCP
MOVE A,CTBL(1)
TLNN A,SSPCF+SSPC2F ;SPECIAL?
JRST SCNGE3 ;NO, RETURN
JUMPE 1,SCNGE2
CAIL 1,12 ;We only want to think about non-printing characters
CAILE 1,15 ;here
JRST SCNGE3
SCNGE2: PUSHJ P,(A) ;Call appropriate routine (better not step in 1!!!)
SCNGE3: POP P,A
POPJ P,
;SCAN Storage, also PUSHBUCTBL and POPBUCTBL
↑CBNO: 0
↑SNCHR: 0
↑PUSHBUCTBL: 0
IFL BUCKNO-6
<FOR I←1,BUCKNO,1
< PUSH P,BUCTBL+I-1
>>
IFGE BUCKNO-6
< MOVE P
HRLI BUCTBL
BLT BUCTBL-1(P)
ADD P,[XWD BUCKNO,BUCKNO]
>
JRST @PUSHBUCTBL
↑POPBUCTBL: 0
IFL BUCKNO-6
<FOR I←1,BUCKNO,1
< POP P,BUCTBL+BUCKNO-I
>>
IFGE BUCKNO-6
< POP P,BUCTBL-1(P)
HRLI BUCTBL
BLT BUCTBL+BUCKNO-1
SUB P,[XWD BUCKNO,BUCKNO]
>
JRST @POPBUCTBL
BEND SCAN
;Initialize symbol table pointers
FOR I←0,BUCKNO-1,1
< .TMP2←I
CAT(SYM,→.TMP2)←←A-1
>
SUBTTL CTBL - The character table
;GOOD BITS FOR EVERYONE ! --- GET YOURS WHILE THEY LAST !
BEGIN CHRTAB
XALL ;TURN OFF MACRO EXPANSION
↑CTBL: XWD DF+SSPC2F,S.NULL ; NULL
REPEAT 3,<ILG> ; ↓ α β
↑ANDV: XWD DF+LOGBIT,ANDOP ; ∧
↑NOTV: ILG ; ¬
ILG ; ε
ILG ; π
ILG ; λ
0 ; HORIZONTAL TAB.
↑LFV: XWD DF+SSPCF,S.LF ; LINE FEED
XWD DF+SSPCF,S.VT ; VERTICAL TAB
XWD DF+SSPCF,S.FF ; FORM FEED
0 ; CARRIAGE RETURN.
ILG ; ∞
ILG ; ∂
XWD RF+RSTMTBT,CBLOCK ; ⊂ (EQUIVALENT TO RESERVED WORD BEGIN)
XWD RF,ENDV ; ⊃ (EQUIVALENT TO RESERVED WORD END)
ILG ; ∩
ILG ; ∪
ILG ; ∀
ILG ; ∃
XWD DF,ALTV ; ⊗ (AN ALTERNATIVE TO ALTMODE FOR FILES)
ILG ; ↔
DOTV-SPACEV ; _
ILG ; →
XWD DF+SSPCF,SENDL ; ~ (↑Z)
↑NEQV: XWD DF+RELBIT,NEOP ; ≠
↑LEV: XWD DF+RELBIT,LEOP ; ≤
↑GEV: XWD DF+RELBIT,GEOP ; ≥
ILG ; ≡
↑ORV: XWD DF+LOGBIT,OROP ; ∨
SPACEV: 0 ; SPACE
DOTV-SPACEV ; ! (AN ALTERNATIVE TO _)
↑QUOTEV: XWD DF+SSPCF,S.QUOTE ; "
.-SPACEV ; #
.-SPACEV ; $
ILG ; %
ILG ; &
ILG ; '
↑LPARV: XWD DF,. ; (
↑RPARV: XWD DF,. ; )
XWD DF+MULBIT,MULOP ; *
↑PLSV: XWD DF+ADDBIT,ADDOP ; +
↑COMMAV: XWD DF,COMMOP ; ,
↑MINV: XWD DF+ADDBIT,SUBOP ; -
↑DOTV: XWD SNUMF,"." ; .
XWD DF+MULBIT,DIVOP ; /
↑CTNUM: REPEAT 12,<XWD SDFLG+SNUMF,20+.-CTNUM> ; THE DIGITS.
↑COLONV: XWD DF+SSPCF,S.COLN ; :
↑SEMICV: XWD DF,. ; ;
↑LTV: XWD DF+SSPCF,S.LT ; < (SEE S.LT IN SCANNER)
↑EQV: XWD DF+RELBIT,EOP ; =
↑GTV: XWD DF+RELBIT,GOP ; >
ILG ; ?
ILG ; @
CTLTR: REPEAT =5,<XWD 0,41+.-CTLTR> ;UPPER CASE LETTERS
41+.-CTLTR ;F
REPEAT =9,<41+.-CTLTR>
XWD FOOBIT,41+.-CTLTR+400000 ;P
REPEAT 4,<41+.-CTLTR>
XWD FOOBIT,41+.-CTLTR
REPEAT 5,<41+.-CTLTR>
↑LFTBRK: XWD DF,. ; [
ILG ; \
↑RGTBRK: XWD DF,. ; ]
↑UARV: XWD DF,EXPOP ; ↑
↑LARV: XWD DF,ASNOP ; ←
ILG ; `
.LCASE: REPEAT =5,<141+.-.LCASE> ;lower case letters
141+.-.LCASE ;f
REPEAT =9,<141+.-.LCASE>
XWD FOOBIT,141+.-.LCASE+400000 ;p
REPEAT 4,<141+.-.LCASE>
XWD FOOBIT,141+.-.LCASE ;u
REPEAT 5,<141+.-.LCASE>
REPEAT 2,<ILG> ;{|
↑ALTV: XWD DF,. ;<ALTMODE>
REPEAT 2,<ILG> ;}<BS>
LALL ;TURN MACRO EXPANSION BACK ON
BEND CHRTAB
; END OF CHARACTER TABLE.
SUBTTL The Reserved word table
DEFINE PUT1 (N,Y)
< FOR X IN (Y)
<Q←<SIXBIT/X/>
N*10000000000+(7777777777&(Q/100))
>>
DEFINE .LENGTH $(FIRST5,REST)
< .COUNT←←0
FOR CHAR ε <FIRST5$REST>
< .COUNT←←.COUNT+1
>>
;PUT WORD IN RESERVED WORD TABLE
DEFINE RESERV $(LSTLST)
< XLIST
.LASTL←←1 ;LAST LENGTH SEEN (ALSO FOR GENSYMing)
RTBL: FOR LIST2 ⊂ (LSTLST)
< RESER1 LIST2
>
↑LRTBL←←.-RTBL
RTBL2: FOR LIST2 ⊂ (LSTLST)
<RESER2 LIST2
>
↑GRTBL←←.-RTBL
SRTBL3: FOR LIST2 ⊂ (LSTLST)
<RESER3 LIST2
>
↑SRTBL1: FOR @% I←2,.LASTL+1
< IFDEF .RT%I < XWD -.RT%I,RT%I%C
>
IFNDEF .RT%I <0
>>
↑MAXRSZ←←.-SRTBL1+3
SRSFOO: JUMP 2*LRTBL(B)
LIST
>
DEFINE RESER1 %(FIRST5,REST,LH,RH,SYM)
< .LENGTH(FIRST5,REST)
IFG .COUNT-.LASTL
<CAT(RT,→.COUNT)%C: .LASTL←←.COUNT
CAT(.RT,→.LASTL)←←0
>
PUT1(.COUNT,FIRST5)
CAT(.RT,→.LASTL)←←CAT(.RT,→.LASTL)+1
>
DEFINE RESER2 %(FIRST5,REST,HL,RH,SYM)
< .LENGTH(FIRST5,REST)
IFLE .COUNT-5 <0
>
IFG .COUNT-5 <SIXBIT/REST/
>>
DEFINE RESER3 %(FIRST5,REST,LH,RH,SYM)
<↑SYM: XWD LH,RH
>
XALL ;TURN OFF MACRO EXPANSION
BEGIN RSRVTB
; <FIRST 5 CHARACTERS>,<REST OF CHARACTERS>,<GOOD BITS>,<ADDRESS>,<TOKEN NAME>
;
; GENERATES # TABLES
;
;RTBL: ;LIST OF SIXBIT BTYES CONTAINING CHARACTER COUNT AND
; ;THE FIRST FIVE CHARACTERS
;RTBL2: ;LIST OF REMAINING CHARACTERS, CORRESPONING TO ORDER IN
; ;RTBL
;RTBL2: ;LIST OF XWD <RANDOM GOODBITS>,<COMPILER ROUTINE>
; ;CORRESPONING TO ORDER IN RTBL
;SRTBL1: ;XWD <NUMBER OF ENTRYS>,<ENTRY IN RTBL> IN ORDER OF
; ;CHARACTER COUNTS
RESERVE <<DO,, RF+RSTMTBT,COMDO,DOV>
,<IF,, RF+RSTMTBT,COMIF,IFV>
,<PI,, FLTFLG,PI,PIV>
,<END,, RF,.,ENDV>
,<FOR,, RF+RSTMTBT,COMFOR,FORV>
,<DONE,, RF+RSTMTBT,COMDONE,DONEV>
,<ELSE,, RF+RSTMTBT,BADELSE,ELSEV>
,<EXIT,, RF+RSTMTBT,COMEXIT,EXITV>
,<FINI,, RF,.,FINIV>
,<LIST,, RF,.,LISTV>
,<PLAY,, RF,.,PLAYV>
,<STEP,, RF,.,STEPV>
,<THEN,, RF,.,THENV>
,<ARRAY,, RF+DECLBIT,DARR,ARRV>
,<BEGIN,, RF+RSTMTBT,CBLOCK,BEGINV>
,<PRINT,, FUNBIT,.PRINT,PRINTV>
,<UNTIL,, RF,.,UNTILV>
,<WHILE,, RF+RSTMTBT,CWHILE,WHILEV>
,<FINIS,H, RF,.,FINV>
,<I.ONL,Y, RF+RSTMTBT,CIONLY,IONLYV>
,<LENGT,H, FUNBIT,.LEN,LENV>
,<RETUR,N, RF+RSTMTBT,COMRET,RTURNV>
,<RPRIN,T, FUNBIT,.RPRINT,RPRINV>
,<STRIN,G, RF+DECLBIT,.STRIN,STRV>
,<COMME,NT, SSPCF,.COMME,COMV>
,<INTEG,ER, RF+DECLBIT,.INTEG,INTGV>
,<R.PRI,NT, RF+RSTMTBT,COMRPRT,RPRNTV>
,<VARIA,BLE, RF+DECLBIT,DVRBL,VARV>
,<FUNCT,ION, RF+DECLBIT,DFUNC,FUNV>
,<EXTER,NAL, RF+DECLBIT,EXTD,EXTV>
,<INSTR,UMENT, RF+DECLBIT,CINS,INSV>
,<UNIT.,GENERATOR,RF+DECLBIT,.UG,UGV>
>
LALL ;TURN MACRO EXPANSION BACK ON
;Random functions
.PRINT: FUNBIT,,.+1
JSA RA,FOOPRT
BYTE (6) 1,VARPAR,0,0
.RPRIN: FUNBIT,,.+1
JSA RA,@FOOPRT
BYTE (6) 1,VARPAR,0,0
↑.LEN: FUNBIT,,.+2
JSA RA,STRLEN
JSA RA,ARRLEN
BYTE (6) 1,STAPAR,0,1
.INTEG: JFCL ;THE JFCLS INSURE A UNIQUE ADDRESS FOR STRQ AND INTGV
.STRIN: ERROR <Illegal declaration>
COMMENT ⊗ You may not make a declaration of type STRING or INTEGER. ⊗;
BADELSE: ERROR <Dangling ELSE or extraneous ';' in IF...THEN...ELSE statement>
COMMENT ⊗ The statement following the 'THEN' in a IF...THEN...ELSE statement is terminated
by the ELSE and should not have a semicolon after it. ⊗;
JRST BADELSE
BEND RSRVTB
SUBTTL The Main Symbol Table
;HERE'S THE BLOODY SYMBOL TABLE --- A LINKED LIST
;PUT SYMBOL IN SYMBOL TABLE
;NEXT TIME I'M IN SOS I SHOULD FIX THIS
DEFINE ENTSYM &(FIRST5,REST,LH,RH)
< XLIST
.TMP1←←<SIXBIT/ FIRST5/>
FOR .CHAR ε <FIRST5&REST> < .TMP1←←.TMP1+1B5
>
.TMP2←←.TMP1-(.TMP1/BUCKNO)*BUCKNO
CAT(SYM,→.TMP2)
CAT(SYM,→.TMP2)←←$.-1
.TMP1
IFDIF <RH><>< XWD LH,RH >
IFIDN <RH><>< XWD LH,$.+1+(.TMP1/1B5)/6 >
SIXBIT/REST/
LIST
>
XALL ;TURN OFF MACRO EXPANSION
ENTSYM OSCIL,,UGBIT, .+2
COMMENT ⊗ Unit generator *Simple oscillator ⊗;
0
JSP RA,@OSCIL ;POINTER DID NOT RESET WITH '1,5,0,1' IN NEXT!!!!
BYTE (6)4,VARPAR,VARPAR,ARRPAR,ZTMPPART,0,1
;***** JULY 3,71 THIS ENDED '1,TMPPAR,0,1' ****
ENTSYM FOSCI,L,UGBIT, .+3 ;Unit generator *SLIGHTLY FASTER oscil
0 ;WILL NOT CHECK FOR NEG. INCR.!!!!!!
JSP RA,@FOSCIL
BYTE (6)4,VARPAR,VARPAR,ARRPAR,ZTMPPART,0,1
ENTSYM ZOSCI,L,UGBIT, .+3
COMMENT ⊗ Unit generator *Interpolating oscillator ⊗;
0
JSP RA,@ZOSCIL
BYTE (6)4,VARPAR,VARPAR,ARRPAR,ZTMPPART,0,1
ENTSYM ZOSCA,,UGBIT, .+2
COMMENT ⊗ Unit generator *Interpolating oscillator with starting point given ⊗;
JSA RA,INOSCA
JSP RA,@ZOSCA
BYTE (6)5,VARPAR,VARPAR,VARPAR,ARRPAR,TMPPART,0,1
ENTSYM CZOSC,IL,UGBIT, .+3
COMMENT ⊗ Unit generator *Interpolating version of COSCIL ⊗;
0 ;****** THIS NOT NEEDED - SEE ZOSCIL *****
JSP RA,@ZOSCIL
BYTE (6)4,VARPAR,VARPAR,ARRPAR,TMPPART,0,1
ENTSYM SRATE,,VRBLBT, SRATE
COMMENT ⊗ Variable *Sampling rate ⊗;
↑SRATE: 10000.0
ENTSYM NCHNS,,VRBLBT, NCHNS
COMMENT ⊗ Variable *Number of channels active ⊗;
↑NCHNS: 1
;; ENTSYM LSBUF,,VRBLBT, LSBUF
;;↑LSBUF: 1000 ; ⊗ Variable *Current size of DAC buffer ⊗;
ENTSYM OUT,,UGBIT, .+2
COMMENT ⊗ Unit Generator *Equivalent to OUTA←OUTA+X ⊗;
0
JSA RA,@OUT
BYTE (6)1,VARPAR,0,0
ENTSYM OUT2,,UGBIT, .+2
COMMENT ⊗ Unit Generator *Equivalent to ≤FUNCTION OUT2(X,CH1,CH2); BEGIN
OUTA←OUTA+X*CH1; OUTB←OUTB+X*CH2; END;≥ ⊗;
0
JSA RA,@OUT2
BYTE (6)3,VARPAR,VARPAR,VARPAR,0,0
ENTSYM SPEED,,VRBLBT, SPEED
COMMENT ⊗ Variable *Speed at which to run DAC (see SETCLOCK) ⊗;
↑SPEED: 1
ENTSYM VFMUL,T,UGBIT, .+3
COMMENT ⊗ Unit Generator *Multiplies amplitude by array element ⊗;
0
JSP RA,@VFMULT
BYTE (6)3,VARPAR,VARPAR,ARRPAR,0,T
ENTSYM NOSCI,L,UGBIT, .+3
COMMENT ⊗ Unit Generator *Oscillator which accepts negative increments ⊗;
0
JSP RA,@NOSCIL
BYTE (6)4,VARPAR,VARPAR,ARRPAR,ZTMPPAR,0,1
ENTSYM NOSCA,,UGBIT, .+2
COMMENT ⊗ Unit generator *Oscillator with starting point given ⊗;
JSA RA,INOSCA
JSP RA,@NOSCA
BYTE (6)5,VARPAR,VARPAR,VARPAR,ARRPAR,TMPPAR,0,T
ENTSYM INTRP,,UGBIT, .+2
COMMENT ⊗ Unit generator *Interpolator driven by oscillator ⊗;
JSA RA,IINTRP
JSP RA,@INTRP
BYTE (6)5,VARPAR,VARPAR,TMPPAR,ARRPAR,ZTMPPAR,0,T
ENTSYM ZINTR,P,UGBIT, .+3
COMMENT ⊗ Unit generator *Interpolator driven by interpolating oscillator ⊗;
JSA RA,IINTRP
JSP RA,@ZINTRP
BYTE (6)5,VARPAR,VARPAR,TMPPAR,ARRPAR,ZTMPPAR,0,T
ENTSYM OUTA,,VRBLBT+RVBT, OUTA
COMMENT ⊗ Variable *Output channel A ⊗;
ENTSYM OUTB,,VRBLBT+RVBT, OUTB
COMMENT ⊗ Variable *Output channel B ⊗;
ENTSYM OUTC,,VRBLBT+RVBT, OUTC
COMMENT ⊗ Variable *Output channel C ⊗;
ENTSYM OUTD,,VRBLBT+RVBT, OUTD
COMMENT ⊗ Variable *Output channel D ⊗;
ENTSYM MAXSM,P,VRBLBT+RVBT, MAXSMP
COMMENT ⊗ Variable *Maximum sample seen ⊗;
ENTSYM P.ARR,AY,ARRYBT, PBASE
COMMENT ⊗ Array *P1,P2,P3,... ⊗;
ENTSYM DEBUG,FLAG,VRBLBT, DEBUGF
COMMENT ⊗ Variable *Enables various compiler debugging features ⊗;
ENTSYM NOMSG,,VRBLBT, NOMSG ;=1= DON'T PRINT VARIOUS MSGS.
↑NOMSG: 0
;; ENTSYM NO.MS,G,VRBLBT, NO.MSG
COMMENT ⊗ Variable *If nonzero, disable compiler messages ⊗;
ENTSYM BITS,,VRBLBT, BITS ;TO SET BYTESIZE
COMMENT ⊗ Variable BYTE SIZE 12.0 OR 18.0 ⊗;
↑BITS: 12.0 ; DEFAULT VALUE
ENTSYM MTA,,VRBLBT, MTA ;TO SET MTA WRITEOUT
↑MTA: 0 ; DEFAULT VALUE, NON-ZERO WRITES ON MTA0
ENTSYM MTADU,R,VRBLBT+RVBT, MTADUR
↑MTADUR:0 ;TO PUT DURATION ON MTA HEADER
ENTSYM OUTFI,LE,VRBLBT!STRFLG, OUTFIL
COMMENT ⊗ String *Output specification ⊗;
ENTSYM INFIL,E,VRBLBT!STRFLG, INFILE
ENTSYM INFIL,2,VRBLBT!STRFLG, INFIL2
ENTSYM INFIL,3,VRBLBT!STRFLG, INFIL3
ENTSYM INFIL,4,VRBLBT!STRFLG, INFIL4
COMMENT ⊗ FOR READIN FILE NAMES ⊗;
;; ENTSYM SAVIT,,VRBLBT, SAVIT ;TO SET SAVE FEATURE
;;↑SAVIT: 0 ; DEFAULT VALUE (NO SAVE)
ENTSYM SAVCN,T,VRBLBT+RVBT, SAVCNT
COMMENT ⊗ FOR SAVE FEATURE ⊗;
↑SAVCNT:0
;;; ENTSYM .SKIP,.,VRBLBT, .SKIP.
COMMENT ⊗ Variable *Used by obscure external routines to record failures ⊗;
ENTSYM VALUE,,UGBIT, .+2
COMMENT ⊗ Unit generator *Returns its first argument ⊗;
0
JSP RA,@VALUE
BYTE (6)1,VARPAR,0,T
ENTSYM RAND,,FUNBIT
COMMENT ⊗ Function *Returns a pseduo-random number between -1 and 1 ⊗
PUSHJ P,RAND
BYTE (6)0,T
ENTSYM INT,,FUNBIT
COMMENT ⊗ Function *Returns integer part of floating point number ⊗;
JSA RA,INT
BYTE (6)1,VARPAR,0,0
ENTSYM ARRBL,T,FUNBIT
COMMENT ⊗ Function *Copies N elements between two arrays ⊗;
JSA RA,ARRBLT
BYTE (6)3,VARPAR,VARPAR,INTPAR,0,1
ENTSYM ABS,,FUNBIT
COMMENT ⊗ Function *Returns absolute value of number ⊗;
JSA RA,[ABS: 0
MOVM 1,@(RA)
JRA RA,1(RA)]
BYTE (6)1,VARPAR,0,1
ENTSYM LINEN,,UGBIT, .+2
COMMENT ⊗ Unit Generator *Three part oscillator ⊗;
JSA RA,LINEN1
JSP RA,@LINEN
BYTE (6)13,ZTMPPART,ZTMPPART,ZTMPPART,VARPAR,VARPAR
BYTE (6)VARPAR,VARPAR,ARRPAR,VARPAR,ZTMPPART,ZTMPPART,0,1
;NOW YOU MUST RESET PTR IN LINEN
ENTSYM EXPEN,,UGBIT, .+2
COMMENT ⊗ Unit Generator *Oscillator which doesn't wrap around ⊗;
0
JSP RA,@EXPEN
BYTE (6)4,VARPAR,VARPAR,ARRPAR,ZTMPPART,0,1
ENTSYM ZEXPE,N,UGBIT, .+3
COMMENT ⊗ Unit Generator *Interpolating oscillator without wrap around ⊗;
0
JSP RA,@ZEXPEN
BYTE (6)4,VARPAR,VARPAR,ARRPAR,ZTMPPART,0,1
ENTSYM REV1,,UGBIT, .+2
COMMENT ⊗ Unit Generator *Comb Filter (Reverberator) ⊗;
JSP RA,REVI
JSP RA,@REV1
BYTE (6)6,VARPAR,VARPAR,VARPAR,ARRPAR,TMPPAR,ZTMPPART,0,1
ENTSYM REV2,,UGBIT, .+2
COMMENT ⊗ Unit Generator *All-Pass Reverberator ⊗;
JSP RA,REVI
JSP RA,@REV2
BYTE (6)6,VARPAR,VARPAR,VARPAR,ARRPAR,TMPPAR,ZTMPPART,0,1
ENTSYM DELAY,,UGBIT, .+2
COMMENT ⊗ Unit Generator *Simple Delay ⊗;
JSP RA,REVI
JSP RA,@DELAY
BYTE (6)6,VARPAR,VARPAR,TMPPAR,ARRPAR,TMPPAR,ZTMPPART,0,1
ENTSYM REVIN,IT,VRBLBT, REVINI
COMMENT ⊗ Unit generator *If nonzero, reverberator arrays are zeroed when
initialized ⊗;
↑REVINI: 0
ENTSYM RANDH,,UGBIT, .+2
COMMENT ⊗ Unit generator *Oscillator controlled random numbers with hold ⊗
JSP RA,IRANDH
JSP RA,@RANDH
BYTE (6)4,VARPAR,VARPAR,ZTMPPART,ZTMPPART,0,1
ENTSYM RANDI,,UGBIT, .+2
COMMENT ⊗ Unit generator *Oscillator controlled random numbers with
interpolation ⊗
JSP RA,IRANDI
JSP RA,@RANDI
BYTE (6)5,VARPAR,VARPAR,ZTMPPART,ZTMPPART,ZTMPPART,0,1
ENTSYM COSCI,L,UGBIT, .+3 ;COSCIL AND NOSCIL ARE SAME
COMMENT ⊗ Unit generator *Oscillator which remembers pointer between
instrument calls ⊗;
0
JSP RA,@NOSCIL
BYTE (6)4,VARPAR,VARPAR,ARRPAR,TMPPAR,0,1
LALL ;TURN MACRO EXPANSION BACK ON
SUBTTL Statement Compilation
;<Statement list> ::= <Statement>;<Statement list> | END
SSTATL: PUSHJ P,SMCSCN ;SCAN NEXT NON-SEMICOLON.
STATL: CAME A,ENDV
PUSHJ P,STAT ;NO. SCAN A STATEMENT.
ORM H,RSTATE ;SAVE R-STATE
CAMN A,ENDV ;IS IT AN END ?
POPJ P, ;YES.
CAMN A,SEMICV ;IS IT A SEMICOLON?
JRST SSTATL ;YES, GO BACK FOR MORE.
WARN <Missing ';'> ;OH WELL...
COMMENT ⊗ Statements should be terminated with a semicolon ⊗;
JRST STATL
;<statement> ::= <assignment statement>|<function call>|<unit generator call>|
; <block>|<for statement>
SSTAT: PUSHJ P,SMCSCN
STAT: MOVEI H,0 ;CLEAR 'R-TIME CODE' FLAG.
JUMPGE A,STMT1 ;A DELIMITER ?
TLNE A,RSTMTBT ;RESERVED WORD FOR STATEMENT
JRST (A)
TLNE A,DECLBIT
JRST [ OUTPUT TTY,
WARN <Declarations should be made at start of block>
COMMENT ⊗ You may continue from this error. ⊗;
JRST (A)]
WARN <Unexpected symbol beginning a statement>
COMMENT ⊗ It will be ignored and attempt to continue compilation. ⊗;
JRST SSTAT
;<STMT1> ::= <FUNCTION CALL> | <UNIT GENERATOR CALL> | <ASN. STMT>
SSTMT1: PUSHJ P,SCAN
STMT1: SKIPN A ;IS IT UNDEFINED ?
ERROR <UNDEFINED IDENTIFIER>
TLNE A,FUNBIT
JRST [ CAMN A,PRINTV ;IS IT A PRINT STATEMENT?
JRST COMPRT ;YES, COMPILE
CAMN A,RPRINV ;IS IT A RPRINT STATEMENT?
JRST COMRPRT
PUSHJ P,FUNCAL ;NO, IT'S A FUNCTION CALL
JRST SCAN] ;RETURN.
TLNE A,UGBIT
JRST [ TRNN FL,INSDEF ;BETTER BE AN INSTRUMENT DEFINITION
ERROR <Unit Generator call illegal outside of instrument definition>
COMMENT ⊗ Unit generators are only to be used inside of instruments as they require
special initialization at I-time. ⊗;
PUSHJ P,UGCALL ;COMPILE A UNIT GENERATOR CALL
JRST SCAN]
TLNN A,ARRYBT!VRBLBT!FOOBIT ;BETTER BE A VARIABLE.
JRST [ WARN <Unexpected symbol beginning a statement>
COMMENT ⊗ It will be ignored and attempt to continue compilation. ⊗;
JRST SSTAT ]
PUSH OSP,A ;STACK IT.
TLNE A,ARRYBT ;IS IT AN ARRAY?
PUSHJ P,SCSUBSC ;YES, COMPILE SUBSCRIPT
STMT1B: PUSHJ P,SCAN ;GET LEFT ARROW.
CAMN A,LARV
JRST STMT1C
CAME A,EQV ;CATCH A COMMON ERROR (= FOR ←) BUT ACCEPTABLE NOW.
ASNERR: ERROR <Expected to find a '←' here> ;THE FATAL ONE
COMMENT ⊗ The compiler assumed you had begun an assignment statement. ⊗;
;;;; WARN <PLEASE Use a '←' assignment next time>
COMMENT ⊗ However '=' will be accepted under protest. ⊗;
STMT1C: PUSHJ P,ASTMT1 ;IT'S AN ASSIGNMENT STMT. COMPILE IT.
JRST POPAJ ;RESTORE A(WHICH WAS SAVED BY ASTMT)
; AND RETURN.
SMSC1:
SMCSCN: PUSHJ P,SCAN ;SCAN PAST NEXT SEMICOLON.
SMCS1: CAMN A,SEMICV
JRST SMCSCN
POPJ P,
;ANOTHER DECLARATION
EXTD: PUSHJ P,SCAN ;"EXTERNAL" DECLARATION.
CAMN A,UGV
JRST UGDEF
CAME A,FUNV ;BETTER BE "FUNCTION".
ERROR <External functions only, please>
COMMENT ⊗ The compiler does not know about anything else being external. ⊗;
TRO FL,EXTFLG ;SET FLAG.
PUSHJ P,DFUNC
TRZ FL,EXTFLG ;CLEAR IT
POPJ P,
;I DON'T KNOW QUITE WHERE TO PUT THIS SO IT GOES HERE.
;<I-only statement> ::= I_ONLY <statement>
;
CIONLY: PUSH P,IONLY ;SAVE AND THEN SET IONLY FLAG
SETOM IONLY
PUSHJ P,SSTAT ;COMPILE RANDOM STATEMENT
POP P,IONLY ;RESTORE STATE OF IONLY
POPJ P, ;RETURN
; Block Statement (BEGIN...END)
;
;<block> ::= BEGIN <statement list>; END
;
CBLOCK: DEBUG2 <ENTERING BLOCK>
AOS BLEVEL ;INCREMENT BLOCK LEVEL
JSR PUSHBUCTBL ;SAVE SYMBOL TABLE POINTERS
PUSH P,EXITFX ;SAVE OLD FIXUP
SETZM EXITFX
PUSH P,EXITFX+1
SETZM EXITFX+1
PUSHJ P,SCAN ;SKIP OVER 'BEGIN'
CBLOC1: PUSHJ P,SMCS1 ;SCAN OPTIONAL ';'
JUMPGE A,CBLOC2
TLNN A,DECLBIT ;A DECLARATION?
JRST CBLOC2 ;NO
PUSHJ P,(A) ;YES, DO DECLARATION
CAME A,SEMICV ;BETTER BE A SEMICOLON
WARN <Missing ';'> ;OH WELL
COMMENT ⊗ Statements should be terminated with a semicolon ⊗;
JRST CBLOC1
CBLOC2: PUSHJ P,STATL
MOVE H,RSTATE ;SET H TO R-TIME STATUS OF BLOCK
SETZM RSTATE
SKIPN A,EXITFX ;ANY EXIT STATEMENTS?
JRST CBLOC3 ;NO
TLO A,CHAINBT ;A CHAIN FIXUP
MOVEI B,.FXBTS
PUSHJ P,EMICD
SKIPN A,EXITFX+1;ANY R-TIME FIXUPS?
JRST CBLOC3 ;NO
TLO A,CHAINBT ;A CHAIN FIXUP
PUSHJ P,EMCD
CBLOC3: POP P,EXITFX+1
POP P,EXITFX
JSR POPBUCTBL ;RESTORE SYMBOL TABLE POINTERS
DEBUG2 <LEAVING BLOCK>
SOSL BLEVEL
JRST SCAN ;SCAN AND RETURN
ERROR <Too many END statements>
; DONE, EXIT, and RETURN
;
COMDONE: SKIPGE B,DONEFX ;FOR CHAIN FIXUP, ALSO CHECK TO MAKE SURE DONE IS OK
ERROR <DONE statement illegal here>
MOVE A,ILOC
MOVEM A,DONEFX ;NEW LINK IN CHAIN
SETZ A,
MOVE C,[JRST EMICDI]
PUSHJ P,EMINST ;EMIT JRST TO END OF LOOP STATEMENT
SKIPE IONLY ;I-TIME ONLY?
JRST SCAN ;YES, SCAN AND RETURN
MOVE B,DONEFX+1 ;FOR R-TIME TOO, THEN
MOVE A,RLOC
MOVEM A,DONEFX+1
SETZ A,
MOVE C,[JRST EMCDI]
PUSHJ P,EMINST ;EMIT JRST TO END OF LOOP STATEMENT
JRST SCAN ;YES, SCAN AND RETURN
COMEXIT: SKIPGE B,EXITFX
ERROR <EXIT statement illegal outside of block>
MOVE A,ILOC
MOVEM A,EXITFX ;NEW LINK IN CHAIN
SETZ A,
MOVE C,[JRST EMICDI]
PUSHJ P,EMINST ;EMIT JRST TO END OF LOOP STATEMENT
SKIPE IONLY ;I-TIME ONLY?
JRST SCAN ;YES, SCAN AND RETURN
MOVE B,EXITFX+1 ;FOR R-TIME TOO, THEN
MOVE A,RLOC
MOVEM A,EXITFX+1
SETZ A,
MOVE C,[JRST EMCDI]
PUSHJ P,EMINST ;EMIT JRST TO END OF LOOP STATEMENT
JRST SCAN ;YES, SCAN AND RETURN
COMRET: PUSHJ P,SCAN
MOVEM A,SAVSYM ;SAVE SYMBOL
PUSHJ P,STMTRM ;IS IT A STATEMENT TERMINATOR?
JRST COMRE2 ;YES, NO VALUE
PUSHJ P,EXPR ;COMPILE A EXPRESSION
MOVEM A,SAVSYM
PUSHJ P,GMURK1 ;GET IT OFF STACK.
SETZ A,
MOVE B,E ;AND READY TO EMIT INSTRUCTION
MOVSI C,(<MOVE>)
CAME B,[XWD SIACBT,0] ;IS IT ALREADY IS AC 0?
PUSHJ P,EMINST ;NO, LOAD INTO AC 0
COMRE2: SKIPGE B,RETFIX
ERROR <RETURN statement illegal outside of function definition>
COMMENT ⊗ Only functions may return a value. Use EXIT to leave a block. ⊗;
MOVE A,ILOC
MOVEM A,RETFIX
SETZ A,
MOVE C,[JRST EMICDI]
PUSHJ P,EMINST ;EMIT JRST TO END OF FUNCTION DEFINITION
MOVE A,SAVSYM ;RESTORE SAVED SYMBOL
POPJ P,
; PRINT Statement
;
;<PRINT statement> ::= PRINT <print list>|R_PRINT <print list>
;<print list> ::= <expression>,<print list>|<expression>|
; <string constant>,<print list>|<string constant>
;
;Code generated for numeric PRINT
; JSA RA,FOOPRT
; <pointer to value>
;
;Code generated for string PRINT
; TTYUUO 3,<address of string>
;
COMRPRT: MOVEI 1
SKIPN IONLY ;DON'T UNDO THIS, IT WILL CAUSE PROBLEMS!
MOVEM RPRINT ;SET R-TIME PRINT KLUDGE FLAG
SKIPA
COMPRT: SETZM RPRINT# ;MORE OF THAT KLUDGE
PUSHJ P,SCAN ;GET NEXT IDENTIFIER
TLNE A,STRFLG ;IS IT A STRING?
JRST [ MOVE B,A ;EMIT AN OUTSTR!
TLZ B,STRFLG ;STRFLG CONFUSES THE LOADER!
TLNE B,777777 ;IS IT A FORMAL OR SOMETHING
HRR B,(B) ;YES, GET REAL ADDRESS
MOVEI A,3 ;OUTSTR = TTYUUO 3,STRING_ADDRESS
MOVSI C,(<TTYUUO>)
TLNE B,VRBLBT ;A string variable?
TLO C,20 ;Turn on indirect bit
SKIPE RPRINT ;IS IT R-TIME KLUDGE?
HRRI C,EMCDI ;YES, BARF!
PUSHJ P,EMINST
PUSHJ P,SCAN ;GET NEXT SYMBOL
JRST COMPR2] ;GO BACK FOR MORE
PUSHJ P,EXPR ;NO, IT MUST BE AN EXPRESSION
PUSH P,A ;SAVE SCANNED CHARACTER
OR H,RPRINT ;R_PRINT KLUDGE
PUSHJ P,GMURK1 ;GET EXPRESSION
TLNE E,FPARBT ;IS IT A FORMAL?
JRST [ PUSHJ P,GETAC ;YES, COPY PARAMETER INTO TEMPORARY
MOVE B,E
MOVSI C,(<MOVE>)
PUSHJ P,EMINST ;EMIT FETCH FOR PARAM.
MOVE B,VLOC
MOVEM B,E ;CHANGE ADDRESS OF PRINT ARG. TO TEMP.
MOVSI C,(<MOVEM>)
PUSHJ P,EMINST ;EMIT STORE INTO TEMP.
PUSHJ P,EMDV ;SAVE SPACE FOR TEMP
JRST COMPR3]
COMPR3: MOVE A,[JSA RA,FOOPRT] ;EMIT A FUNCTION CALL TO PRINT NUMBER
SETZ B,
PUSHJ P,@EMITB(H)
MOVE B,E
SETZB A,C
PUSHJ P,EMINST ;EMIT IT
POP P,A ;GET BACK SCANNED SYMBOL
COMPR2: CAMN A,COMMAV ;IS IT A COMMA?
JRST COMPRT ;YES, GET ANOTHER THING TO PRINT
POPJ P, ;NO, RETURN
; IF-THEN-ELSE statement
;
;<IF-THEN statement> ::= IF <expression> THEN <statement> ELSE <statement>|
; IF <expression> THEN <statement>
;
;Code Generated for IF-THEN Code generated for IF-THEN-ELSE
; <Skip on condition true> <Skip on condition true>
; JRST G0001 JRST G0001
; SETOM <flag> SETOM <flag>
; <True statement> <True statement>
; JRST .+2 JRST G0002
;G0001: SETZM <flag> G0001: SETZM <flag>
; <False statment>
; G0002:
;
COMIF: PUSHJ P,SLEXPR ;COMPILE THE CONDITIONAL PART
CAME A,THENV
WARN (Missing 'THEN')
COMMENT ⊗ 'THEN' Missing in IF...THEN...ELSE Statement. ⊗;
JUMPN H,COMRIF ;IF IT WAS AN R-TIME CONDITIONAL
MOVE A,VLOC ;EMIT CODE TO SKIP IN R-TIME CODE ACCORDING TO
HLRZ B,VLOC ;A CERTAIN FLAG WE'RE ABOUT TO CREATE
HRLI A,(<SKIPN>)
SKIPN IONLY ;DON'T BOTHER IF WE'RE JUST GENERATING I-TIME CODE
PUSHJ P,EMCDI
PUSH P,VLOC ;SAVE ADDRESS OF THIS CERTAIN FLAG
SKIPN IONLY ;IF WE MAY BE GENERATING R-TIME CODE, INC. THE
AOS VLOC ;VARIABLE COUNTER
PUSH P,RLOC ;AND THE ADDRESSES OF THE FOLLOWING 'JRST' FOR FIXUPS
PUSH P,ILOC ;(G0001)
MOVSI A,(<JRST>)
SETZ B,
PUSHJ P,EMICDI ;TO JUMP AROUND 'THEN' PART ON CONDITION FALSE
SKIPN IONLY ;DO WE NEED TO DO IT FOR R-TIME TOO?
PUSHJ P,EMCDI ;YES, EMIT IT THEN
MOVE A,-2(P) ;STACK = [...FLAG, R-FIXUP, I-FIXUP]
HRLI A,(<SETOM>)
HLRZ B,VLOC
SKIPN IONLY
PUSHJ P,EMICDI ;AND EMIT CODE TO SET THAT FLAG
PUSHJ P,SSTAT ;COMPILE A STATEMENT
CAMN A,ELSEV ;DOES IT HAVE AN 'ELSE` CLAUSE?
JRST CIELSE ;YES, GO SOMEWHERE ELSE TO DO IT.
PUSH OSP,A ;SAVE IT ON THE OPERAND PDL FOR CONVIENCE
HRRZ A,ILOC
ADD A,[JRST 2] ;(FASTER THAN A SKIP) SKIP OVER I-TIME CODE TO
HLRZ B,ILOC ;SET FLAG FOR USE BY R-TIME
SKIPN IONLY ;UNLESS WE'RE JUST COMPILING I-TIME CODE
PUSHJ P,EMICDI
COMIF7: PUSHJ P,[ ;DO FIXUPS FOR I-TIME AND R-TIME CODE (G0001)
;STACK = [...FLAG, R-FIXUP, I-FIXUP, RETURN ADDRESS]
;(FLUSHES TOP TWO STACK ELEMENTS + RETURN ADDRESS)
FIXBTH: POP P,A ;GET RETURN ADDRESS
EXCH A,-1(P) ;SWAP IT WITH R-TIME FIXUP
MOVEI B,.FXBTS
SKIPN IONLY ;DON'T BOTHER IF WE JUST COMPILING I-TIME
PUSHJ P,EMCD ;FIXUP FOR R-TIME
POP P,A ;DO I-TIME FIXUP
PUSHJ P,EMICD
POPJ P,] ;RETURN
PUSHJ P,[ ;EMIT CODE TO SKIP FLAG (FLUSHES TOP OF STACK + R.A.)
;STACK = [...FLAG, RETURN ADDRESS]
CLRSKP: POP P,A ;GET FLAG FOR R-TIME SKIP
EXCH A,(P)
HRLI A,(<SETZM>);TO CLEAR IT IF CONDITION FALSE
HLRZ B,VLOC ;GET VARIABLE RELOCATION
SKIPN IONLY ;BUT DON'T EMIT IF WE JUST COMPILING I-TIME CODE
PUSHJ P,EMICDI
POPJ P,]
OPOPAJ: POP OSP,A ;GET BACK SCANNED SYMBOL
POPJ P, ;AND RETURN
CIELSE: MOVSI A,(<JRST>);EMIT JRST TO AROUND 'ELSE` CLAUSE (JRST G0002)
SETZ B,
PUSHJ P,EMICDI ;FOR I-TIME
SKIPN IONLY ;AND R-TIME CODE IF NECESSARY
PUSHJ P,EMCDI
PUSHJ P,FIXBTH ;DO FIXUPS FOR JRSTS TO 'ELSE` CLAUSE (G0001)
PUSHJ P,CLRSKP
PUSH P,RLOC ;AND SAVE POINTERS FOR OTHER FIXUPS (G0002)
SOS (P) ;BLETCH!
PUSH P,ILOC
SOS (P)
SKIPN IONLY
SOS (P)
PUSHJ P,SSTAT ;COMPILE THE 'ELSE` CLAUSE
PUSH OSP,A
PUSHJ P,FIXBTH ;DO FIXUPS TO JRST AROUND 'ELSE' CLAUSE (G0002)
JRST OPOPAJ
; IF-THEN-ELSE statement - (R-TIME)
COMRIF: MOVSI A,(<JRST>);EMIT JRST AROUND 'THEN` CLAUSE
SETZ B,
PUSH P,RLOC ;SAVE FOR FIXUP
PUSHJ P,EMCDI
PUSHJ P,SSTAT ;COMPILE 'THEN` CLAUSE
PUSHJ P,IFRCHK ;MAKE SURE SOMETHING WAS GENERATED AT R-TIME
CAMN A,ELSEV ;IS THERE AN 'ELSE` CLAUSE?
JRST CRELSE ;YES, JUMP OFF TO COMPILE IT
COMIF8: EXCH A,(P) ;SAVE SCANNED SYMBOL AND GET ADDRESS OF JRST TO FIXUP
MOVEI B,.FXBTS ;AND THE FIXUP BITS
PUSHJ P,EMCD
JRST POPAJ ;RECOVER SCANNED SYMBOL AND RETURN
;AN R-TIME ELSE
CRELSE: MOVSI A,(<JRST>);EMIT JRST AROUND THE 'ELSE` CLAUSE
SETZ B,
PUSHJ P,EMCDI
MOVE A,RLOC
SUBI A,1 ;BLETCH!
EXCH A,(P) ;SAVE POINTER TO PREVIOUS JRST AND GET FIXUP FOR
MOVEI B,.FXBTS ;JRST TO ELSE CLAUSE
PUSHJ P,EMCD ;EMIT FIXUP
PUSHJ P,SSTAT ;COMPILE THE 'ELSE` CLAUSE
PUSHJ P,IFRCHK ;MAKE SURE THERE WAS SOMETHING GENERATED AT R-TIME
JRST COMIF8 ;FIXUP THE JRST AROUND 'ELSE` CLAUSE, RECOVER
;SCANNED SYMBOL AND RETURN!
IFRCHK: MOVE B,-1(P) ;WAS THERE ANY R-TIME CODE GENERATED?
ADDI B,1
CAMN B,RLOC
WARN <R-Time conditional for I-time IF-THEN-ELSE statement> ;NO!!!
COMMENT ⊗ No R-time code was generated after an R-Time conditional. Therefore
the IF-THEN statement acts as if the condition were always true for the 'THEN'
clause and always false for the 'ELSE' clause! ⊗;
POPJ P,
; WHILE statement
;
; THIS COULD BE RECODED TO BE MORE EFFICIENT BY USING NEW DONES IN PLACE OF
; SAVING G0002 ON THE STACK
;
;<WHILE statement> ::= WHILE <expression> DO <statement>
;
;Code Generated:
;G0001: <Skip on condition true>
; JRST G0002
; <Statement>
; JRST G0001
;G0002:
;
CWHILE: DEBUG(WHILE statement)
PUSH P,DONEFX ;SAVE DONE FIXUPS
PUSH P,DONEFX+1
SETZM DONEFX
SETZM DONEFX+1
PUSH P,ILOC ;SAVE ADDRESS OF BEG. OF WHILE
PUSH P,RLOC
PUSHJ P,SLEXPR ;COMPILE CONDITION
CAME A,DOV ;BETTER BE A 'DO`
WARN <Missing DO in WHILE statement>
MOVSI A,(<JRST>);GET READY TO EMIT JRST AROUND STATEMENT
SETZ B,
JUMPN H,CRWHILE ;HANDLE R-TIME SEPARATELY
POP P,(P) ;FLUSH SAVED R-TIME POINTER
PUSH P,ILOC ;SAVE ADDRESS OF JRST AROUND STATEMENT
PUSHJ P,EMICDI
PUSH P,IONLY ;NO, MARK IT I-TIME ONLY CODE
SETOM IONLY
PUSHJ P,SSTAT ;COMPILE THE STATEMENT PART
POP P,IONLY ;RESTORE I-ONLY FLAG
EXCH A,-1(P) ;SAVE SCANNED SYMBOL AND GET POINTER TO BEG. OF
HLRZ B,A ;WHILE STATEMENT TO EMIT JRST BACK
HRLI A,(<JRST>)
PUSHJ P,EMICDI
POP P,A ;EMIT FIXUP TO JRST AROUND STATEMENT
MOVEI B,.FXBTS
PUSHJ P,EMICD
POP P,SAVSYM# ;RECOVER SCANNED SYMBOL
JRST LOOPDN
;R-TIME WHILE STATEMENT
CRWHIL: PUSH P,RLOC ;SAVE POINTER FOR FIXUP
PUSHJ P,EMCDI ;EMIT JRST AROUND STATEMENT
PUSHJ P,SSTAT ;COMPILE THE STATEMENT PART
MOVE B,(P)
ADDI B,1
CAMN B,RLOC ;WAS ANY R-TIME CODE GENERATED
WARN <R-Time condition for I-Time Statement in WHILE statement> ;NO!!!
COMMENT ⊗ No R-Time code was generated after an R-Time conditional. It is
most likely that this will result in an infinite loop! ⊗;
EXCH A,-1(P) ;SAVE SYMBOL AND GET ADDRESS OF BEG. OF WHILE
HLRZ B,A
HRLI A,(<JRST>) ;EMIT A JRST BACK TO BEGINNING OF WHILE
PUSHJ P,EMCDI
POP P,A ;EMIT FIXUP AROUND STATEMENT
MOVEI B,.FXBTS
PUSHJ P,EMCD
POP P,SAVSYM# ;RECOVER SCANNED SYMBOL
POP P,(P) ;FLUSH I-TIME POINTER
; DO ANY FIXUPS REQUIRED BY DONES, ETC
LOOPDN: MOVEI B,.FXBTS
SKIPN A,DONEFX ;ANY I-TIME DONE STATEMENTS?
JRST LOOPD1 ;NO
TLO A,CHAINBT ;A CHAIN FIXUP
PUSHJ P,EMICD
LOOPD1: SKIPN A,DONEFX+1;AND ANY R-TIME DONE FIXUPS?
JRST LOOPD2 ;NO
TLO A,CHAINBT ;A CHAIN FIXUP
PUSHJ P,EMCD
LOOPD2: MOVE A,SAVSYM
POP P,DONEFX+1 ;RESTORE OLD FIXUP POINTERS
POP P,DONEFX
POPJ P, ;AND RETURN
; UNTIL statement
;
;<Until Statement> ::= DO <statement> UNTIL <condition>;
;
;Code Generated:
;G0001: <Statement>
; <Skip if condition true>
; JRST G0001
;
COMDO: DEBUG (UNTIL statement)
PUSH P,DONEFX ;SAVE DONE FIXUPS
PUSH P,DONEFX+1
SETZM DONEFX
SETZM DONEFX+1
PUSH P,RLOC ;SAVE FOR APPROPRIATE FIXUP
PUSH P,ILOC
PUSHJ P,SSTAT ;COMPILE A STATEMENT
PUSH P,IONLY ;SAVE STATE OF I-ONLY FLAG
CAME A,UNTILV ;BETTER BE AN 'UNTIL`
WARN (Missing 'UNTIL')
COMMENT ⊗ UNTIL missing from DO ... UNTIL statement or extraneous ';`.⊗;
SKIPN H
SETOM IONLY ;SET THE I-TIME ONLY FLAG
PUSHJ P,SLEXPR ;COMPILE A LOGICAL EXPRESSION WHICH SKIPS ON TRUE
EXCH A,(P) ;SAVE SYMBOL AND GET RLOC
SKIPN H
SKIPE IONLY
SKIPA
ERROR <Can't have an R-time statement controlled by an I-time conditional>
COMMENT ⊗ The DO ... UNTIL statement will never terminate under such circumstances. ⊗;
POP P,IONLY
POP P,B
SKIPE H ;IS IT R-TIME
MOVE B,A ;YES, USE R-TIME LOC
SETZ A,
MOVSI C,(<JRST>);EMIT JUMP BACK TO STATEMENT
PUSHJ P,EMINST
POP P,SAVSYM
JRST LOOPDN ;RESTORE SCANNED SYMBOL AND RETURN
; FOR Statement
;
;<for statement> ::= FOR <variable>←<expression> STEP <expression> UNTIL
; <expression> DO <statement>
;
;CODE GENERATED:
; MOVE A,<initial expression> ;MAY BE AN AC OTHER THAN 'A`
; JRST G0001 ;SKIP OVER INCREMENT
;G0002: MOVE A,<increment expression>
; ADD A,<for variable> ;INCREMENT FOR VARIABLE
;G0001: CAMLE A,<terminal expression> ;FINISHED?
; JRST DONE ;YES
; MOVEM A,<for variable> ;STORE IS DONE AFTER COMPARE
; <statement> ;DO STATEMENT
; JRST G0002 ;GO GET NEXT VALUE
;DONE: ;FOR VARIABLE CONTAINS LAST
; ;VALUE BELOW TERMINAL VALUE
;
COMFOR: DEBUG (FOR statement)
PUSH P,DONEFX ;SAVE DONE FIXUPS
PUSH P,DONEFX+1
SETZM DONEFX
SETZM DONEFX+1
PUSHJ P,SCANV ;SCAN FOR VARIABLE
SKIPN A
ERROR <UNDEFINED IDENTIFIER>
COMMENT ⊗ An identifier was used before it was declared. ⊗;
TLNE A,VRBLBT ;IS IT A VARIABLE?
TLNE A,STRFLG ;And not a string
ERROR <Simple variable required here>
COMMENT ⊗ FOR loops expect a simple variable, i.e. not an array. ⊗;
PUSH OSP,A ;SAVE IT TWICE, ONCE FOR INCREMENT
PUSH OSP,A ;ONCE FOR STORE
PUSH P,IONLY ;SAVE OLD IONLY FLAG
TLNN A,RVBT ;R-TINE VARIABLE?
SETOM IONLY ;NO, SET IONLY FLAG
PUSHJ P,SCAN ;GET '←'
CAME A,LARV ;BETTER BE
WARN <Missing '←' in FOR>
PUSHJ P,SEXPR ;COMPILE INITIAL EXPRESSION
PUSH P,A ;SAVE SYMBOL
PUSHJ P,SRTIMI ;SET R-TIME FLAG IF NEEDED
PUSHJ P,GMURK1 ;GMURK THE INITIAL EXPRESSION
SETZ A,
MOVE B,E
MOVSI C,(<MOVE>)
PUSH P,ILOC(H) ;EMIT A MOVE INTO AC TO BE DECIDED
PUSHJ P,EMINST ;UPON LATER
SETZB A,B
MOVSI C,(<JRST>);EMIT JRST AROUND INCREMENTING PART
PUSHJ P,EMINST
POP P,A ;GET BACK SAVED SYMBOL
EXCH A,(P)
CAMN A,UNTILV
JRST [ PUSH OSP,[XWD FLTFLG,[1.0]]
JRST CFOR1 ]
CAME A,STEPV ;SHOULD BE A 'STEP'
WARN <Missing 'STEP' in FOR>
PUSHJ P,SEXPR ;COMPILE INCREMENTING EXPRESSION
CAME A,UNTILV ;MAKE SURE IT'S FOLLOWED BY 'UNTIL'
WARN <Missing 'UNTIL' in FOR>
CFOR1:
MOVE A,(OSP)
MOVEM A,INCSYM#
PUSHJ P,ADDGEN ;DO INCREMENTING
MOVE A,(P) ;DO A FIXUP OF AC FOR FOREMENTIONED MOVE
TLO A,400000 ;INDICATE TO USE NEXT WORD FOR FIXUP
MOVEI B,.FXBTS
PUSHJ P,@EMITB2(H);EMIT FIXUP TO MOVE INSTRUCTION FORM PROPER AC
HRLZ A,(OSP) ;GET AC INTO PROPER PLACE IN INSTRUCTION
LSH A,5
SETZ B,
PUSHJ P,@EMITB2(H);EMIT 2ND WORD OF FIXUP
AOS A,(P) ;GET NEXT LOCATION IN CODE FOR JRST TO SKIP
MOVEI B,.FXBTS ;INCREMENT
PUSHJ P,@EMITB2(H);FIX THAT ONE UP, TOO
MOVE T,(OSP)
PUSHJ P,GPMARK ;DON'T USE AC CONTAINING VARIABLE!
PUSHJ P,SEXPR ;COMPILE FINAL EXPRESSION
CAMN A,DOV ;BETTER BE A 'DO`
JRST [ PUSHJ P,SCAN
JRST .+2 ]
WARN (Missing 'DO' in FOR)
PUSH P,A ;SAVE FIRST SYMBOL OF NEXT STATEMENT
PUSHJ P,SRTIMI ;SET R-TIME IF NEEDED
PUSH OSP,-1(OSP);COPY AC CONTAINING VALUE TO ASSIGN
MOVE A,INCSYM ;PICK UP INCREMENT VALUE
TLNE A,NUMFLG ;IS IT A CONSTANT
TLNE A,SUBSBT
JRST CFOR2
SKIPGE (A) ;IS IT NEGATIVE?
SKIPA A,GTV ;YES, DO OPPOSITE FLAVOR OF COMPARE
CFOR2: MOVEI A,LOP ;END TEST FOR LESS THAN OR EQUAL
PUSH P,[XWD 4000,0] ;PUSH MAGIC SKIP COMPLIMENT BIT
PUSHJ P,(A) ;EMIT END TEST
POP P,(P) ;FLUSH MAGIC SKIP COMPLIMENT BIT
SETZ A, ;EMIT A JRST TO END OF STATEMENT TO BE FIXED
MOVE B,ILOC(H) ;THIS IS THE SAME AS A DONE STATEMENT!
EXCH B,DONEFX(H)
MOVSI C,(<JRST>);UP LATER
PUSHJ P,EMINST
PUSHJ P,ASNGEN ;NOW STORE THE NEW VALUE OF FOR VARIABLE
POP P,A ;RESTORE SYMBOL
PUSHJ P,STAT ;COMPILE THE STATEMENT
MOVEM A,SAVSYM ;SAVE TERMINATOR
PUSHJ P,SRTIMI ;SET R-TIME IF NEEDED
SETZ A,
AOS B,(P) ;EMIT JRST BACK TO INCREMENT PART
MOVSI C,(<JRST>)
PUSHJ P,EMINST
POP P,(P) ;POP JUNK OFF STACK
POP P,IONLY ;NOW RESTORE I-TIME ONLY FLAG
JRST LOOPDN ;HANDLE DONE STATEMENTS
SRTIMIF:SKIPN IONLY ;SET R-TIME FLAG IF NEEDED
MOVEI H,1
POPJ P,
SUBTTL Recursive Expression Analyzer.
;THIS HERE IS THE COMPILER !
;<EXPR> ::= <EXPR2>!<EXPR2><LOGOP><EXPR2>
SEXPR: PUSHJ P,SCAN
EXPR: PUSH P,LOGFLG ;SAVE STATE OF LOGFLG
SETOM LOGFLG ;LET SCANNER SEE '<` AS OPERATOR
PUSHJ P,EXPR2
POP P,LOGFLG ;RESTORE STATE OF LOGFLG
TLNE A,DF ;A DELIMITER?
TLNN A,RELBIT+LOGBIT ;A LOGICAL ONE AT THAT?
POPJ P, ;NO, RETURN
PUSH P,[EXPR8] ;FAKE RETURN ADDRESS
PUSH P,LOGFLG
SETOM LOGFLG
PUSH P,[0] ;MAGIC SKIP COMPLIMENT BIT IS OFF
PUSH P,[LEXPR2] ;ANOTHER FAKE RETURN ADDRESS
JRST RELEX2 ;TO CALL LEXPR AFTER SCANNING AN EXPR2
EXPR8: PUSH P,A ;SAVE SCANNED SYMBOL
PUSHJ P,LXPGEN ;CONVERT A SKIP CONDITION INTO A NUMBER
JRST POPAJ ;RECOVER SAVED SYMBOL AND RETURN
SCLEXPR: PUSHJ P,SCAN ;SCAN FIRST
CLEXPR: PUSH P,LOGFLG ;SAVE STATE OF LOGFLG
SETOM LOGFLG ;LET SCANNER SEE '<` AS OPERATOR
PUSH P,[XWD 4000,0] ;PUSH MAGIC SKIP COMPLIMENT BIT
JRST LEXPR1
SLEXPR: PUSHJ P,SCAN ;SCAN FIRST
LEXPR: PUSH P,LOGFLG ;SAVE STATE OF LOGFLG
SETOM LOGFLG ;LET SCANNER SEE '<` AS OPERATOR
PUSH P,[0] ;PUSH A ZERO INSTEAD OF MAGIC COMPLIMENT BIT
LEXPR1: PUSHJ P,RELEXPR ;PARTIALLY COMPILE RELATIONAL
LEXPR2: TLNE A,DF ;A DELIMITER NEXT?
TLNN A,LOGBIT ;AND IS IT A LOGICAL OPERATOR?
JRST .+2 ;NO
JRST (A) ;CALL APPROPRIATE GENERATOR
EXCH A,-1(P) ;NEITHER, COMPILE IT STRAIGHT, GET MAGIC COMPLIMENT
;BIT AND SAVE SCANNED SYMBOL
EXCH A,(P) ;SAVE MAGIC COMPLIMENT SYMBOL AND GET OPERATOR
PUSHJ P,(A) ;CALL GENERATOR AND RETURN
POP P,(P) ;FLUSH MAGIC COMPLIMENT BIT
POP P,A ;RESTORE SAVED SYMBOL
POP P,LOGFLG ;RESTORE STATE OF LOGFLG
POPJ P,
SRELEXP: PUSHJ P,SCAN
RELEXP: PUSHJ P,EXPR2 ;GET FIRST HALF
TLNE A,DF ;A DELIMITER NEXT?
RELEX2: TLNN A,RELBIT ;AND IS IT A RELATIONAL OPERATOR?
JRST RELEX9 ;NO, TREAT IT AS <expr>≠0
EXCH A,(P) ;SAVE TERMINATOR UNDER RETURN ADDRESS
PUSH P,A
PUSHJ P,SEXPR2 ;COMPILE SECOND EXPRESSION
TLNE A,DF
TLNN A,RELBIT ;NEXT A RELATIONAL OPERATION?
POPJ P, ;RETURN
ERROR (Use of two relational operator is illegal here)
COMMENT ⊗ The compiler doesn't know how to deal with expression like
'2>X>9'. Write it as two conditions. ⊗;
RELEX9: PUSH P,A ;SAVE TERMINATOR
MOVE A,NEQV
EXCH A,-1(P) ;SAVE '≠` UNDER WHERE RETURN ADDRESS WILL BE
EXCH A,(P) ;AND GET TERMINATOR
PUSH OSP,[[XWD FLTFLG,$.+1
0]-1] ;PUSH A ZERO ONTO OPERAND STACK
POPJ P, ;RETURN
;<EXPR> ::= <TERM> ! <TERM><ADDOP><EXPR>
SEXPR2: PUSHJ P,SCAN
EXPR2: DEBUG (EXPR)
PUSHJ P,TERM
EXPR1: TLNE A,DF ;A DELIMITER NEXT ?
TLNN A,ADDBIT ;YES. AN ADD OR SUBTRACT OP. ?
POPJ P, ;NO.
PUSH P,A ;YES. LOOK FOR ANOTHER TERM.
PUSHJ P,STERM ;THIS IS ITERATIVE INSTEAD OF
; RECURSIVE IN ORDER TO PROCESS FROM LEFT TO
EXCH A,(P) ; RIGHT.
PUSHJ P,(A) ;CALL APPROPRIATE GENERATOR.
POP P,A
JRST EXPR1
;<TERM> ::= <FACTOR>!<FACTOR><MULOP><FACTOR>
STERM: PUSHJ P,SCANV
TERM: PUSHJ P,FACTOR
TERM1: TLNE A,DF ;A DELIMITER NEXT ?
TLNN A,MULBIT ;YES. A MULTIPLY OR DIVIDE OP ?
POPJ P, ;NO.
PUSH P,A
PUSHJ P,SFACTOR
EXCH A,(P)
PUSHJ P,(A)
POP P,A
JRST TERM1
SFACTOR:PUSHJ P,SCANV
FACTOR: JRST PRIMARY ;GOOD ENOUGH FOR NOW ...
; Primarys
;<primary> ::= -<primary>|(<expr>)|<array>(<expr>)|<function call>|
; <unit generator call>|<variable>|<constant>
SPRIM: PUSHJ P,SCAN
PRIMARY: JUMPE A,UDIERR ;STILL UNDEFINED ?
TLNN A,DF ;IS IT A SPECIAL CHAR. ?
JRST PRIM3 ;NO.
PRIM2: CAMN A,MINV ;UNARY MINUS ?
JRST [ PUSHJ P,SPRIM ;YES, SCAN A PRIMARY.
PUSH P,A
PUSHJ P,UMGEN ;CALL GENERATOR.
JRST POPAJ] ;RESTORE A AND RETURN.
CAME A,LPARV ;NO. IT BETTER BE A (.
ERROR (Illegal primary)
PRIM4: PUSHJ P,SEXPR ;SCAN AN EXPRESSION.
CAME A,RPARV ;LOOK FOR MATCHING PAREN.
WARNSK <Missing ')' in expression>
COMMENT ⊗ Unbalanced parentheses or missing operator in expression. ⊗;
JRST SCAN ;SCAN AND RETURN.
POPJ P,
PRIM3: TLNE A,FUNBIT ;THE NAME OF A FUNCTION ?
JRST [ PUSHJ P,FUNCAL ;COMPILE THE FUNCTION CALL.
PUSHJ P,MRKAC0 ;MARK AC0 FULL (VALUE OF FUNCTION).
;I QUESTION THE ABOVE LINE OF CODE, SHOULDN'T BE PUSHJ P,MRKAC (SEE FNOPR+1)
JRST SCAN] ;RETURN.
TLNE A,UGBIT ;THE NAME OF A UNIT GENERATOR?
JRST [ TRNN FL,INSDEF
ERROR <Unit generator call illegal outside of instrument definition>
COMMENT ⊗ Unit generators are only to be used inside of instruments as they require
special initialization at I-time. ⊗;
PUSH P,UGEXPF ;SAVE STATE OF FLAG TO INDICATE WE WANT A VALUE
SETOM UGEXPF ;FROM THIS UNIT GENERATOR
PUSHJ P,UGCALL ;COMPILE CALL ON UNIT GENERATOR
POP P,UGEXPF ;RESTORE STATE OF FLAG
PUSHJ P,MRKAC ;MAKE AC1 FULL (VALUE OF FUNCTION)
JRST SCAN] ;YES, CALL IT
SVRBL: TLNN A,VRBLBT!SWVBT!NUMFLG!FOOBIT ;SHOULD BE A VARIABLE,ARRAY NAME
ERROR <Illegal primary> ;NUMBER OR FOO SYM.
COMMENT ⊗ Should be a number, variable, array or function call. ⊗;
TLNE A,VRBLBT!NUMFLG!FOOBIT ;IS IT AN ARRAY NAME ?
JRST SVRBL2 ;NO.
; HRR A,(A) ;YES. GET R. HALF OF GOOD BITS.
; SUBI A,2 ;MAKE IT POINT TO ARRAY[-2].
PUSH OSP,A ;STASH THE ARRAY NAME
PUSHJ P,SCAN ;CHECK FOR LELAND'S CROCKISH Pn←<array name>;
CAMN A,SEMICV
JRST [ LELAN0: ;YES, THAT'S LELAND'S
PUSH OSP,A ;SAVE TERMINATOR
HRRZ A,-4(P) ;MAKE SURE IT'S AN ASSIGNMENT STATEMENT!
CAIE A,LELAN1 ;WAS IT CALLED FROM ASTMT1?
JRST LELAN2 ;NO. PRINT MISSING '('...
MOVE A,-1(OSP) ;YEP, GET ARRAY NAME BACK
HRR A,(A) ;YES. GET R. HALF OF GOOD BITS.
SUBI A,2 ;MAKE IT POINT TO ARRAY[-2].
MOVEM A,-1(OSP) ;SAVE IT ON STACK
POP OSP,A ;RETURN
POPJ P,]
PUSHJ P,CSUBSC ;COMPILE SUBSCRIPT
JRST SVRBL1 ;DON'T CHECK FOR NUMBERS
SVRBL2: SKIPE IONLY ;TURN OFF R-TIME FLAG IF WE'RE JUST GENERATING I-TIME
TLZ A,RVBT ;CODE.
PUSH OSP,A ;MAY BE AN ASN. STMT....
TLNE A,NUMFLG ;IF IT IS A NUMBER, IT CAN'T BE LEFT
JRST SCAN ;PART OF ASN. STMT.
SVRBL1: PUSHJ P,SCAN ;GET LEFT ARROW,IF ANY.
CAME A,LARV ;IT IS ONE, ISN'T IT ?
POPJ P, ;NOPE. JUST A GARDEN VARIETY VARIABLE.
PUSHJ P,ASTMT1 ;YES. COMPILE IT.
PUSHJ P,MRKAC ;SINCE IT'S A PRIMARY, REMEMBER ITS
JRST POPAJ ;VALUE, THEN RETURN.
ASTMT1: ;COMPILE ASSIGNMENT STMT...
PUSHJ P,SCAN ;Read a symbol to check for a string
TLNE A,STRFLG ;If it's a string, don't try to compile a expression!
JRST [ PUSH OSP,A
PUSHJ P,SCAN
JRST LELAN1 ]
PUSHJ P,EXPR ;COMPILE RIGHT PART OF STMT.
LELAN1: ;THIS IS THE RETURN ADDRESS WHICH MUST BE CHECKED
;TO PERMIT Pn←<array name> (SEE
EXCH A,(P) ;SAVE 'A' UNDERNEATH RETURN ADR.
PUSH P,A
JRST ASNGEN ;GENERATE THE STORE.
; Compile a Subscript for Array Reference
SCSUBS: PUSHJ P,SCAN
CSUBSC: CAMN A,LFTBRK ;SHOULD BE A '['
JRST .+3
CAME A,LPARV ;ACCEPT A "("
LELAN2: WARN <Missing '(' after array>
COMMENT ⊗ You are probably trying to use a array as a variable. Arrays must be
subscripted. ⊗;
PUSH P,NOTAC0 ;DON'T USE AC0!
SETOM NOTAC0
PUSHJ P,SEXPR ;COMPILE THE SUBSCRIPT
POP P,NOTAC0 ;OK NOW
CAMN A,COMMAV
ERROR <Multiply dimensioned arrays not implemented>
COMMENT ⊗ You may also have confused an array name with a function name. ⊗;
CAMN A,RGTBRK ;ACCEPT A ']'
JRST .+3
CAME A,RPARV
WARN <Missing ')' after array subscript>
MOVSI A,SUBSBT ;TURN ON THE SUBSCRIPT BIT IN STACK
HRRZ T,OSP
TDNE A,(T) ;IS TOP OF STACK A SUBSCRIPT?
SOJA T,.-1 ;SEARCH FOR ONE WHICH ISN'T!
CAIG T,OSTK ;BETTER NOT BE BELOW SECOND STACK ELEMENT
PUSHJ P,DRYROT ;OOPS!
ORB A,(T)
TLNE A,.FXBTS+LFXBTS
JRST NSTRSB
TLNE A,STRFLG ;Better not be a string!!!
ERROR <You can't subscript an array with a string!>
COMMENT ⊗ An array can only be subscripted by something that evaluates to
be a number. ⊗;
NSTRSB: CAIN T,(OSP) ;IF NOT TOP OR
TLNN A,SIACBT+SRACBT ;NOT AN AC THEN RETURN
POPJ P,
POP OSP,A ;GET AC OFF THE STACK AND MARK IT
JRST MRKAC ;IN AC TABLE
SUBTTL Compile a Function Call.
;<Function calls> ::= <identifier>(<parameter list>)
;<parameter list> ::= <parameter>,<parameter list>|<parameter>|
;<parameter> ::= <expression>|<array>
FUNCAL: DEBUG (FUNC. CALL)
FUNCA2: PUSH P,RLOC ;SAVE R-TIME CODE LOC. CTR.
HRRZ B,(A) ;GET PTR. TO PARAMETER DESCRIPTORS.
PUSH P,B ;PTR. TO SYMBOL TABLE ENTRY.
PUSH OSP,(B) ;PLACE CALLING INSTR. ON OPND. STK.
PUSH P,[POINT 6,0,35] ;MAKE A PTR. TO THE BYTES
HRRM B,(P) ; OF THE PARAMETER DESRIPTION.
ILDB T,(P) ;GET PARAMTER COUNT.
PUSH P,T
JUMPE T,FNOPR ;IF NO PARAMS., CALL GENERATOR.
PUSHJ P,SCAN ;SWALLOW LEFT PAREN.
CAMN A,LFTBRK ;OR LEFT BRACKET
JRST FUNC2A
CAME A,LPARV ;I HATE PEOPLE WHO DO THIS.
SKWARN <Missing '(' in function call> ;THAT'S BETTER
JRST FUNC4 ;IN THE ERROR CASE
FUNC2A: PUSHJ P,SCAN ;SCAN FIRST PARAM.
FUNC4: PUSH P,A
FUNC1: ILDB T,-2(P) ;GET NEXT PARAM. DESCRIPTOR.
CAIN T,ZTMPPAR ;IS IT A DUMMY PARAMETER. ?
JRST [ PUSHJ P,GDPAR ;YES, GENERATE A ZEROED DUMMY PARAM.
JRST FUNC1]
CAIN T,TMPPAR ;OR A TYPE 2 DUMMY ?
JRST [ PUSH OSP,[0] ;YES, EMIT A DUMMY PARAM., BUT WITHOUT
JRST FUNC1] ;ANY INSTR. TO ZERO IT AT I-TIME.
POP P,A ;NO.
JUMPE T,FLPAR ;IF =0,NO MORE PARAMS.
CAME A,RPARV ;NO PARENTHESES OR COMMAS HERE, PLEASE.
CAMN A,COMMAV
ERROR (Too few arguments in function call)
CAIN T,ARRPAR ;MUST THIS PARAM. BE AN ARRAY NAME ?
JRST [FUNC1T: ;YES, PARAMETER IS NAME OF ARRAY.
PUSHJ P,GAPAR ;CALL GENERATOR.
PUSHJ P,SCAN ;GET TERMINATOR
JRST FUNC2]
CAIN T,INTPAR ;IS IT TO BE AN INTEGER ?
JRST [ PUSHJ P,EXPR ;YES, CALCULATE EXPRESSION
PUSH P,A ;SAVE TERMINATOR
PUSHJ P,FIXGEN ;CONVERT TO INTEGER IF NECESSARY
POP P,A ;RESTORE TERMINATOR
JRST FUNC2] ;GET NEXT
CAIN T,STRPAR ;MUST THIS PARAM. BE A STRING CONSTANT?
JRST [ TLNN A,STRFLG ;YES, CHECK IT, AND CLEAR IT AS IT IS AN INDEX
ERROR (STRING REQUIRED HERE)
COMMENT ⊗ Something other than a string found as an argument to a function
which expected a string as (one of) its arguments. ⊗;
FUNC1S: PUSHJ P,GSPAR ;CALL GENERATOR
PUSHJ P,SCAN ;GET TERMINATOR
JRST FUNC2]
CAIN T,STAPAR
JRST [ ;SPECIAL HACK SO 'LENGTH' ACCEPTS STRING!!!
TLNN A,STRFLG
JRST FUNC1T ;NOT A STRING, USE ARRAY
SOS B,-2(P)
MOVE B,(B) ;CALL FOR STRING PRECEDES CALL FOR ARRAY
MOVEM B,(OSP)
JRST FUNC1S ]
TLNE A,STRFLG ;A string?
ERROR(NUMERIC ARGUMENT REQUIRED HERE)
COMMENT ⊗ A string was found where a numberic argument was expected. ⊗;
PUSHJ P,EXPR ;NO, LET IT BE AN EXPRESSION.
FUNC2: CAMN A,COMMAV ;IS IT A COMMA ?
FUNC3: PUSHJ P,SCAN ;YES, ALTHOUGH WE DONT REALLY CARE.
JRST FUNC4
FLPAR: CAMN A,COMMAV
SKWARN <Too many parameters in function call>
JRST [FLPAR1: PUSHJ P,SCAN ;LET'S ASSUME LOSER PUT IN ONE TOO MANY
TLNN A,DF ;IS IT A DELIMITER?
JRST FLPAR1 ;NO, TRY ANOTHER
JRST FLPAR2] ;YES, HOPE IT'S A ')'
FLPAR2: CAMN A,RGTBRK ;LAST PARAM. IS FOLLOWED BY EITHER ')' OR ']'
JRST FNOPR
CAME A,RPARV
WARN <Missing ')' or too many parameters in function call> ; ... OR ELSE.
FNOPR: PUSHJ P,GFUNC ;CALL GENERATORS.
ILDB A,-1(P) ;GET NO. OF AC CONTAINING RESULT.
HLL A,MRKTAB(H) ;GET SOME GOODBITS
SUB P,[XWD 4,4] ;FORGET ABOUT THINGS IN STACK.
POPJ P,
SUBTTL Code Generators
; HERE ARE THE GLORIOUS, SUPER-INTELLIGENT, SCHIZOPHRENIC
; CODE GENERATORS. LOOK UPON THEM AND BE AMAZED.
MULGEN: SKIPA T,[FMPR] ;GENERATE A MULTIPLY.
ADDGEN: MOVSI T,(<FADR>);SEE THE STUPID FAIL !
PUSH P,T
PUSHJ P,NUMCHK ;CHECK FOR BOTH BEING CONSTANTS
PUSHJ P,GGET1 ;GET ONE OPERAND IN AN AC.
GEN1: POP P,C ;RECOVER THE OPCODE.
GEN2: TLNN B,FLTFLG ;IS IT A FLOATING POINT NUMBER?
JRST GEN2A ;NO
TLNE B,17 ;IS IT RELOCATED?
JRST GEN2A ;%$$%&%# D. POOLE (SEE SNUMNO)! WE CAN'T OPTIMIZE!
HRRZ T,(B) ;GET THE RIGHT HALF OF ITS VALUE
JUMPN T,GEN2A ;IF IT'S ZERO, WE CAN MAKE AN IMMEDIATE
ADD C,[XWD 1000,0];INSTRUCTION OUT OF IT
HLRZ B,(B) ;GET VALUE (RELOCATIONS BITS = 0)
GEN2A: PUSHJ P,EMINST ;EMIT THE INSTRUCTION.
PUSHJ P,MRKAC ;MARK THE AC FULL
POPJ P,
DIVGEN: SKIPA T,[FDVR] ;GENERATE A DIVIDE ...
SUBGEN: MOVSI T,(<FSBR>); .. OR A SUBTRACT.
PUSH P,T
PUSHJ P,NUMCHK ;CHECK FOR BOTH BEING CONSTANTS
PUSHJ P,GGET2 ;GET FIRST OPERAND IN AN AC.
JRST GEN1
UMGEN: PUSHJ P,GMURK1
PUSH P,[MOVN]
PUSHJ P,NUMCH1 ;CHECK FOR CONSTANTS
PUSH P,E
PUSHJ P,GETAC ;GET A FREE AC.
POP P,B ;BRING BACK AC ADDRESS.
; MOVSI C,(<MOVN>);EMIT GOOD INSTRUCTION.
POP P,C ;RECOVER OPCODE
JRST GEN2A
FIXGEN:
IFN KI10SW,< PUSH P,[KIFIX] >
IFE KI10SW,< PUSH P,[KAFIX 233000] >
PUSHJ P,GMURKA ;CHECK FOR CONSTANTS
TLNE E,FIXFLG ;IS IT ALREADY FIXED?
JRST [ POP P,(P) ;YES, THROW OUT OPCODE
POPJ P,] ;YES, RETURN
PUSHJ P,NUMCH1 ;CHECK TO SEE IF IT'S A NUMBER AND DEAL WITH IT
PUSHJ P,GG2 ;GET IT INTO AC
POP P,C
MOVE B,A ;Same address as AC for KI10 (i.e. FIX X,X)
JRST GEN2A ;EMIT IT AND MARK ITS AC
LXPGEN: PUSHJ P,GETACN ;GET ANY AC EXCEPT AC0
MOVE B,A ;EMIT CODE TO CLEAR AC AND SKIP
MOVSI C,(<TDZA>);FOR THE FALSE CASE
PUSHJ P,EMINST
MOVEI B,(1.0) ;EMIT CODE TO LOAD 1.0 FOR TRUE CASE
MOVSI C,(<MOVSI>)
PUSHJ P,EMINST
JRST MRKAC ;MARK IT IN USE
LOP: CAIA (<CAML>) ;A TABLE OF OPCODE FOR RELATIONALS
EOP: CAIA (<CAME>) ;LOTS OF FAST NOPS
LEOP: CAIA (<CAMLE>)
GEOP: CAIA (<CAMGE>) ;CALLED WITH OPERATOR IN 'A'
NEOP: CAIA (<CAMN>)
GOP: JFCL (<CAMG>)
RELGEN: HRLZ A,(A) ;GET OPCODE
PUSH P,A ;SAVE IT
MOVE T,(OSP) ;Check first arg. for string
TLNN T,.FXBTS+LFXBTS ;Relocatable
TLNN T,STRFLG ;or not string?
JRST RELGN2
JRST RELGER
RELGN2: MOVE T,-1(OSP) ;Check second argument
TLNN T,.FXBTS+LFXBTS ;Relocatable?
TLNN T,STRFLG ;and not string
JRST RELGN3
RELGER: ERROR <Attempt to do numeric operation on a string!>
COMMENT ⊗ String comparison not implemented. ⊗;
RELGN3: PUSHJ P,GGET1 ;GET ONE OF TOP TWO INTO AC
POP P,C
TDC C,-1(P) ;MAGIC SKIP COMPLIMENT BIT!
CAMN B,D ;DID GGET1 SWITCH OPERAND ORDER ON US?
JRST EMINST ;NO, WE CAN EMIT IT NOW
TLNN C,001000 ;IS IT <≤≥>?
JRST EMINST ;NO, LEAVE NOW
TLC C,007000 ;YES, CHANGE IT INTO THE REVERSED KIND OF COMPARE
ADD C,[XWD 1000,0]
JRST EMINST ;NOW WE CAN EMIT IT.
;WE COULD CHECK FOR AN OPERAND BEING A ZERO AND EMIT A SKIP--
;INSTEAD OF A CAM-- BY TURNING ON 20000 BIT IN OPCODE
ASNGEN: ;COMPILE STORE FOR ASIGNMENT STMT.
ASNOP: PUSH P,-1(OSP) ;SAVE PTR. TO GOOD BITS OF VRBL.
PUSHJ P,GMURK ;GET EXPR. AND LEFT-PART VARIABLE.
EXCH D,E ;GET THEM IN RIGHT ORDER.
TLNN D,ARRYBT ;A (numeric) array
TLZN D,STRFLG ;A string assignment? (STRFLG turned off for loader)
JRST [ TLNN E,ARRYBT ;A (numeric) array
TLNN E,STRFLG ;Or not a string?
JRST ASNGE2 ; Yes, OK
TLNE E,.FXBTS ;Better be a temporary
JRST ASNGE2 ; Yes, that's OK
ASNBAD: ERROR(Type mismatch for assignment)
COMMENT ⊗ You are trying to assign a string to a numeric variable or a number
to a string variable! ⊗;
]
TLNN E,ARRYBT ;Other better be a string
TLNN E,STRFLG
JRST ASNBAD ;Type mismatch
TLNE E,VRBLBT ;Variable?
TLZ E,STRFLG ; Yes, clear string flag (confuses loader)
ASNGE2: PUSHJ P,GG2 ;GET EXPR. IN AN AC.
POP P,T ;RECOVER PTR. TO VRBL. GOOD BITS WORD...
MOVSI C,(<MOVEM>) ;EMIT A MOVEM TO STORE VALUE OF EXPR.
JRST EMINST
ADDOP←←ADDGEN
SUBOP←←SUBGEN
MULOP←←MULGEN
DIVOP←←DIVGEN
ANDOP:
OROP: ERROR (Unimplimented operation)
COMMENT ⊗ AND and OR are not implimented. ⊗;
SUBTTL Emit code into code buffers
COMMENT ⊗
These routines put word + relocatation into code buffer. Their
function is determined by their name.
Emit Emit and Counter Word byte Reloc. byte
AOS counter pointer pointer
R-Time reloc. EMCD EMCDI RLOC EMPTR RELPTR
I-Time reloc. EMICD EMICDI ILOC EMIPTR RELIPTR
Variable reloc. EMVCD EMVCDI VLOC EMVPTR RELVPTR
Code is put into temporary buffers until the end of this compilation
when they are loaded by a special loader and then release.
⊗;
EMDV: SETZB A,B ;EMIT A DUMMY VARIABLE (TO RESERVE
; SPACE IN THE VARIABLES AREA).
EMVCDI: AOS VLOC
EMVCD: MOVEI T1,2 ;EMIT TO VARIABLE BUFFER.
JRST ECD
EMIABS: TDZA B,B ;EMIT TO I-TIME BUF. , NO RELOC.
EMCDI: AOSA RLOC ;SKIP INSTRUCTIONS WIN BIG.
EMICDI: AOSA ILOC ; SEE THE HAPPY INTERLEAVED CODE !
EMCD: TDZA T1,T1 ;EMIT TO RUNTIME BUFFER.
EMICD: MOVEI T1,1 ;EMIT TO INITIALIZE TIME BUFFER.
ECD:
IDPB A,EMPTR(T1) ;EMIT THE WORD.
MOVEM A,LSTWRD(T1) ;SAVE LAST WORD EMITTED
IDPB B,RELPTR(T1) ;ALSO ITS RELOCATION BITS.
AOSGE BUFCNT(T1) ;IS BUFFER FULL ?
POPJ P, ;NO. RETURN.
GBUF: ; BUFFER IS FULL; GET A NEW ONE.
MOVNI T,LOBUFS ;LENGTH OF A BUFFER.
PUSHJ P,GFS ;GET SOME FREE STORAGE(WHILE IT LASTS!)
HRLI T,400 ;MAKE BYTE PTR.
MOVEM T,RELPTR(T1) ;PTR. FOR RELOCATION BITS.
MOVEI T2,LOBUFS/12+2(T) ;LEAVE ROOM FOR REL. BITS
HRRM T2,EMPTR(T1) ;DATA PTR.
HRRZM T,@OBPTR(T1) ;FIX UP FORWARD LINKS.
HRRZM T,OBPTR(T1)
SETZM @OBPTR(T1)
MOVNI LOBUFS-LOBUFS/12-3
MOVEM BUFCNT(T1) ;SET UP WORD COUNT.
POPJ P,
EMPTR: POINT 36,0,35 ;DATA OUTPUT POINTERS FOR EACH KIND OF CODE
EMIPTR: POINT 36,0,35
EMVPTR: POINT 36,0,35
RELPTR: POINT 4,0 ;RELOC. BITS PTRS.
RELIPT: POINT 4,0
RELVPT: POINT 4,0
OBPTR: BLOCK 3 ;PTR. TO FIRST WORD OF CURRENT BUFFER FOR
; USE IN FIXING UP FORWARD LINKS.
BUFCNT: BLOCK 3 ;WORD COUNTS FOR BUFFERS.
FCBUF: 0 ;PTR. TO FIRST BUFFER IN EACH CHAIN FOR EACH KIND OF
FICBUF: 0 ;CODE
FVCBUF: 0
SUBTTL GPONDER - Examine top element of operand stack
; HA! I BET YOU THOUGHT WE WERE DONE, DIDN'T YOU ?
; WELL, HERE BEGINS AN INFINITE REGRESSION OF
; CLEVER ,GRUBBY ROUTINES WHICH DO THE
; DIRTY WORK FOR THE GENERATORS.
; GPONDER REMOVES THE TOP THING FROM THE OPERAND STACK,
; LOVINGLY PATS ITS MAGIC BITS INTO STANDARD FORMAT,
; AND SETS A FLAG INDICATING WHETHER IT IS AN
; R-TIME VARIABLE OR NOT.
GPONDER: MOVEI H,0 ;RESET R-TIME VARIABLE FLAG.
GPOND1: POP OSP,T ;GET TOP THING.
TLNE T,SUBSBT ;IS IT A SUBSCRIPT?
JRST GPSUBS ;YES, GENERATE AN ARRAY REFERENCE
SKIPN IONLY ;ARE WE GENERATING ONLY I-TIME CODE
JRST GPOND2 ;NO
TLNE T,SRACBT ;IS IT AN R-TIME AC?
PUSHJ P,DRYROT ;THIS SHOULD NOT HAPPEN!!
JRST GPOND3
GPOND2: TLNE T,SRACBT+RVBT ;AN R-TIME AC OR VARIABLE ?
MOVEI H,1 ;YES. SET R-TIME FLAG.
GPOND3: TLNE T,FOOBIT ;IS IT A FOO-SYMBOL?
JRST GPFOO ;YES.
TLNE T,NUMFLG ;A NUMBER ?
POPJ P, ;YES. WE ARE DONE.
TLNE T,SRACBT ;AN R-TIME AC ?
SETZM RACS(T) ;YES. MARK IT FREE.
TLNE T,SIACBT ;(SAME FOR I-TIME AC).
SETZM IACS(T) ;AC'S WILL ALSO BE PROTECTED AT GPMARK SO THEY
;THEY DON'T GET SWAPPED BEFOORE THEY'RE USED
TLNE T,ACFLAG ;IS IT AN AC?
JRST GPMARK ;YES, PROTECT IT
TLNE T,VRBLBT ;A VARIABLE ?
HRR T,(T) ;YES. GET RT. HALF GOOD BITS.
POPJ P,
;A FOO SYMBOL, MUST BE EITHER Pn OR Un
GPFOO: TRZE T,400000 ;IS IT A P-SYMBOL?
JRST GPONP ;YES.
;WE FOUND A Un
GPONU: SKIPE IONLY
WARN(Attempt to reference unit generator output at I-Time)
COMMENT ⊗ Unit generators output values at R-time, thus at I-time, the
output of a unit generator is undefined. ⊗;
MOVEI H,1 ;REFERS TO A UNIT GENERATOR; SET FLAG.
HRRZS T ;GET NO. OF UNIT GEN.
CAMLE T,UOPTR ;NO FORWARD REFERENCES TO UNIT GEN.
ERROR (Forward ref. to unit generator)
COMMENT ⊗ You have most likely referenced the output of a unit generator which
have not been defined yet. [If there are no Un symbols in the expression, it
may be a compiler bug.]⊗;
MOVE T,UOTBL(T) ;GET ADDRESS OF ITS OUTPUT CELL.
JRST GPFOO2
;WE FOUND A Pn
GPONP: HRRZ T,T ;Don't look at high order bits!!!
CAILE T,LPA ;Too big?
ERROR<Parameter number, Pn, too big>
COMMENT ⊗ The 'n' in 'Pn' is larger than the number of parameters allowed
for instrument calls. This number could be increased upon demand. ⊗;
ADDI T,PBASE ;BASE OF PARAM. ARRAY.
HRLI T,GPBIT ;MARK AS P-SYMBOL.
GPFOO2: TLNE T,SUBSBT ;CHECK FOR SUBSCRIPT
JRST GPSUBS
POPJ P,
;PROTECT AGAINST SWAPPING UNTIL IT SEES AN EMINST
GPMARK: MOVSI T1,NOSWAP ;PROTECT AN AC UNTIL AFTER IT IS USED IN AN EMINST
TLNE T,SRACBT ;AN R-TIME AC ?
JRST[ ORM T1,RACS(T) ;YES, PROTECT IT FREE.
POPJ P,]
TLNE T,SIACBT ;(SAME FOR I-TIME AC).
ORM T1,IACS(T)
POPJ P, ;RETURN
SUBTTL Array Reference Generation
; WE FOUND A SUBSCRIPT ON THE OPERAND STACK.
; WE MUST GET IT INTO AN APPROPRIATE AC, GET THE ARRAY
; POINTER AND MAKE SURE THAT AC DOESN'T GET SWAPPED OUT.
GPSUBS: HRRZ A,(P) ;DO WE HAVE TO LOOK AT SECOND OPERAND TO
CAIE A,GMURK+1 ;DETERMINE R-TIME OR I-TIME
JRST GPSUB1 ;NO, GOOD
MOVE A,-1(OSP) ;UGH, WE HAVE TO CHECKS ITS R-TIME TOO (ALSO -1(OSP) IS
;THE ARRAY POINTER)
TLNE A,SRACBT+RVBT ;TO DO SUBSRIPTING WITH CORRECT
MOVEI H,1 ;FLAVOR OF AC.
GPSUB1: MOVE A,(OSP) ;CHECK FOR F1[F1[I]]
TLNE A,SUBSBT
PUSH P,[GPSUB1] ;WE WANT TO COME BACK LATER IF NESTED ARRAY REFERENCES
MOVE E,T ;SET UP FOR REST OF GMURKING THE SUBSCRIPT
TLNE T,NUMFLG ;CONSTANT?
JRST GPSUB2 ;YES, RETURN VARIABLE INSTEAD OF INDEX ARRAY
TLZ T,SUBSBT ;TURN OFF SUBSCRIPT BIT
PUSH OSP,T ;PUT IT BACK ON STACK MINUS THE SUBSCRIPT BIT
PUSH P,NOTAC0
SETOM NOTAC0
PUSHJ P,GMURK1 ;GMURK IT! (ALSO DOES POP OSP,)
PUSHJ P,GG2 ;GET IT INTO AN APPROPRIATE AC
POP P,NOTAC0
MOVE B,A ;AC=ADR for KI10 FIX
IFE KI10SW,<
MOVEI B,233000 ;MAGIC BITS FOR FIX INSTRUCTION
MOVSI C,(<KAFIX>)
>;IFE KI10SW
IFN KI10SW,<
MOVE B,A ;AC=ADR for KI10 FIX
MOVSI C,(<KIFIX>)
>;IFN KI10SW
PUSHJ P,EMINST ;OUTPUT FIX INSTRUCTION FOR SUBSCRIPT
POP OSP,T ;GET POINTER TO GOODBITS WORD
TLNE T,FPARBT ;IS IT A FORMAL PARAMETER?
JRST GPSUB4 ;OH, WELL...
MOVEM T,ARRGBW# ;SAVE POINTER TO GOODBITS WORD
HRR T,(T) ;GET ADDRESS OF ARRAY
DPB A,[POINT 4,T,17] ;PUT INDEX IN RIGHT PLACE
SKIPE H ;DO NOT DO BOUNDS CHECKING FOR R-TIME CODE!
JRST [ TLO T,RVBT ;TURN ON R-TIME BIT
EXCH A,T ;GET AC INTO 'T'
SETZM RACS(T) ;Free AC after first use.
PUSHJ P,GPMARK ;MARK SUBSCRIPT AC IN USE
EXCH A,T ;GET THING TO RETURN BACK INTO 'A'
POPJ P,] ;RETURN
COMMENT ⊗
MOVE A,<subscript>
FIX A,233000
CAIGE A,<upper limit>
SKIPGE A
PUSHJ P,ILLARF ;%$%#&%$!!!
JUMP <symbol table pointer>
⊗;
PUSH P,T ;SAVE GOODBITS WORD TO BE RETURNED
MOVE B,-1(T) ;GET UPPER BOUND (USE -4(T) FOR SAIL)
MOVSI C,(<CAIGE>);(CAMG FOR SAIL)
PUSHJ P,EMINST ;EMIT CODE TO CHECK UPPER BOUND
PUSH P,A
MOVE B,A
SETZ A,
MOVSI C,(<SKIPGE>)
PUSHJ P,EMINST ;EMIT CODE TO CHECK LOWER BOUND
; MOVE B,-3(T)
; MOVSI C,(<CAMGE>)
; PUSHJ P,EMINST ;FOR SAIL
MOVE A,[PUSHJ P,ILLARF]
SETZ B,
PUSHJ P,EMICDI ;EMIT ERROR CALL
POP P,A ;GET AC OF SUBSCRIPT
HRRZ B,ARRGBW ;GET ARRAY GOODBITS WORD
MOVSI C,(<JUMP>)
PUSHJ P,EMINST ;EMIT POINTER TO GOODBITS (I HATE MYSELF FOR OUTPUT TWO
;WORD HERE. SHOULD BE DONE WITH UUO)
MOVE T,A
SETZM (A)
PUSHJ P,GPMARK ;MARK SUBSCRIPT AC IN USE
POP P,T ;WORDS, GET BACK GOODBITS WORD
POPJ P, ;PROTECT IT
;CONSTANT FOR SUBSCRIPT! WE CAN CALCULATE IT HERE AND TREAT AS IT IS JUST AN
;ORDINARY VARIABLE
GPSUB2: MOVE E,(E)
IFE KI10SW,< KAFIX E,233000 > ;FIX SUBSCRIPT
IFN KI10SW,< KIFIX E,E > ;FIX SUBSCRIPT
POP OSP,T ;GET GOOD BITS WORD
TLNE T,FPARBT ;A FORMAL?
JRST GPSUB3
HRR T,(T) ;GET ADDRESS OF ARRAY
SKIPL E ;CHECK SUBSCRIPT
CAML E,-1(T) ;THIS WON'T WORK WITH SAIL
ERROR (Subscript out of bounds at compile time.)
COMMENT ⊗ You have a subscript expression which evaluates to a constant which
is either too large or too small. ⊗;
ADD T,E ;ADD SUBSCRIPT
TLZ T,ARRYBT
TLO T,VRBLBT ;MAKE IT LOOK LIKE A VARIABLE!!!
POPJ P, ;RETURN!
;AN ARRAY AS A FORMAL PARAMETER WITH CONSTANT SUBSCRIPT
;CODE GENERATED:
; HRRZ A,<PARAMETER NUMBER>(RA)
;LEAVES '<SUBSCRIPT>(A)' ON IN 'T'
;***** Bounds checking should be done on subscript! *****
GPSUB3: MOVE B,(T) ;GET GOODBITS
PUSH P,B ;SAVE B (CLOBBERED BY GETACN)
PUSHJ P,GETACN ;GET AN AC
POP P,B
MOVSI C,(<HRRZ>)
GPSUB5: HRLI B,ARRYBT+RA
PUSHJ P,EMINST
MOVE T,A ;Setup for GPMARK
JUMPN H,[SETZM RACS(T) ;Flush AC after use
JRST GPSUB6]
SETZM IACS(T)
GPSUB6: PUSHJ P,GPMARK ;MARK SUBSCRIPT AC IN USE
MOVSI T,ARRYBT ;GOOD ENOUGH...
HRR T,E
DPB A,[POINT 4,T,17] ;PUT INDEX IN RIGHT PLACE
POPJ P, ;RETURN
;AN ARRAY AS A FORMAL PARAMETER WITH NON-CONSTANT SUBSCRIPT
;CODE GENERATED:
; MOVE A,<SUBSCRIPT>
; FIX A,233000
; ADD A,<PARAMETER NUMBER>(RA)
;LEAVES '(A)' ON IN 'T'
;***** Bounds checking should be done on subscript! *****
GPSUB4: MOVE B,(T)
MOVSI C,(<ADD>)
SETZ E,
JRST GPSUB5 ;IT LOOKS RATHER SIMILAR TO CONSTANT CASE
;GET AN AC BUT NOT AC0
GETACN: PUSH P,NOTAC0
SETOM NOTAC0 ;DON'T USE AC0!
PUSHJ P,GETAC
POP P,NOTAC0
POPJ P,
SUBTTL GMURK - Set up top two elements of stack for code generation
; GMURK CLEVERLY GPONDERS THE TOP TWO OPERANDS,
; AND IF ONE OF THEM IS AN R-TIME VARIABLE
; AND THE OTHER IS AN I-TIME AC OR A P-SYMBOL, IT STORES
; THE LATTER WHERE IT WILL BE SAFE UNTIL R-TIME.
;
; RETURNS LEFT OPERAND IN D
; RETURNS RIGHT OPERAND IN E
;
; GMURKA AND GMURK1 ONLY GMURK THE TOP OPERAND AND LEAVE IT IN E,
; WITH D SET TO ZERO.
GMURKA: MOVEI H,0
GMURK1: TDZA T,T ;PROCESS ONLY TOP STACK ELEMENT.
GMURK: PUSHJ P,GPONDER ;GPONDER THE FIRST OPERAND.
PUSH P,T ;SAVE IT
PUSHJ P,GPOND1 ;NOW THE SECOND.
POP P,D ;PUT THEM BOTH IN SOME SAFE ACCUMULATORS.
MOVE E,T
GM1: SKIPN H ;IS EITHER ONE AN R-TIME VARIABLE ?
JRST ACSRCH ;NO, SEARCH AC'S TO SEE IF EITHER IS IN AN AC
TLNE E,SIACBT+GPBIT ;AN I-TIME AC OR A P-SYMBOL ?
JRST GM2 ;YES.
TLNN D,SIACBT+GPBIT ;HOW ABOUT THIS ONE ?
JRST ACSRCH ;HE ISN'T, EITHER. LOOK FOR BOTH IN R-TIME AC'S
SKIPA F,[EXP D] ;BAGBITING MACROX.
GM2: MOVEI F,E ;SEE THE TWO HEADED MONSTER.
MOVE A,(F) ;GET THE RELEVANT THING.
TLNE A,GPBIT ;A P-SYMBOL, OR AN I-TIME AC ?
JRST GM3 ; A P-SYMBOL.
MOVE B,VLOC ;AN I-TIME AC, STORE IT IN VARIABLE AREA.
GM3B: MOVEM B,(F) ;CHANGE THE OPERAND INDICATOR.
MOVE C,[MOVEM EMICDI] ;EMIT THE STORE INSTRUCTION.
PUSHJ P,EMINST
PUSHJ P,EMDV ;MAKE A PLACE IN THE VARIABLES FOR IT.
JRST ACSRCH ;SEE IF THE OTHER IS IN AN R-TIME AC
;A P-SYMBOL - WE BETTER NOT BE INTERPETING AS IT LOSES AS THERE ARE NUM-
;BERS WHERE WE EXPECT ADDRESSES IN THE P_ARRAY!!!
GM3: TRNN FL,INSDEF ;THIS SHOULD FIX ABOVE PROBLEM
JRST ACSRCH
SKIPN T1,(A) ;HAS THE PARAMETER ALREADY BEEN
JRST GM3A ; PUT IN VAR. AREA ?
MOVEM T1,(F) ;YES. CHANGE POINTER.
JRST ACSRCH ;SEARCH TO SEE IF OTHER IS IN AN R-TIME AC
GM3A: PUSHJ P,GETIAC ;FIND FREE I-TIME AC.
MOVE B,(F)
MOVE T,VLOC ;GET VAR. LOC. CTR.
TLO T,GPBIT
MOVEM T,(B) ;ENTER IN PARAMTER TABLE.
MOVE C,[MOVE EMICDI] ;EMIT INSTR. TO
PUSHJ P,EMINST ;PICK UP THE PARAMETER.
MOVE B,VLOC ;GET LOC. AGAIN...
TLO B,GPBIT ;MARK AS A P-SYMBOL.
JRST GM3B ;NOW STORE THE PARAMETER IN VAR. AREA.
ACSRCH: POPJ P,
; GGET - Gets one of top two stack elements into an AC.
; STILL MORE KLUGES. PAUSE TO GET YOUR BREATH NOW.
; GGET1 ARRANGES TO HAVE ONE OF THE TOP TWO OPERANDS
; IN AN AC.
; RETURNS IN 'A' THE ADDRESS OF THAT AC, AND
; THE ADDRESS OF THE OTHER OPERAND IN 'B', WITH RELOCATION
; BITS IN LEFT HALF.
; CLOBBERS 'C'
; ALSO RETURNS LEFT OPERAND IN 'D' AND
; RIGHT OPERAND IN 'E'
GGET1: PUSHJ P,GMURK ;PROCESS TOP TWO OPERANDS.
TLNN D,SIACBT+SRACBT ;IS FIRST ONE IN AN AC ?
JRST GG2 ;NO.
MOVE A,D ;YES. WE ARE DONE.
MOVE B,E
POPJ P,
GGET2: PUSHJ P,GMURK ;GGET2 GETS SECOND OPERAND IN AN AC.
GG2: MOVE A,E ;PUT OPERAND IN A.
TLNE A,SIACBT+SRACBT ;IS IT ALREADY IN AN AC ?
JRST [ TRNN A,17 ;YES, IS IT AC0?
SKIPN NOTAC0 ;AND WE PROHIBITED FROM USING AC0?
JRST GL2A ;NO. WIN BIG.
SETZ E ;OOPS, WE GET COPY AC0 INTO SOMEONE ELSE!!!
JRST GG2A] ;THIS IS MOST UNFORTUNATE AS WHEN IT GENERATES
;POOR CODE. AND WE DON'T KNOW WHO HE BELONGS TO!!
; TLNE D,SIACBT+SRACBT ;HOW ABOUT OTHER OP. ?
; SETOM @ACTB3(H) ;AN AC... MARK IT FULL TEMPORARILY.
;IT SHOULD ALREADY HAVE BEEN MARKED...
GG2A: PUSHJ P,GETAC ;GET A FREE AC OF THE APPROPRIATE KIND.
TLO E,NOSWAP ;DON'T ALLOW IN TO BE SWAPPED UNTIL IT HAS SEEN
;EMINST
MOVEM E,@ACTB1(H) ;TELL WORLD WHAT IT WILL CONTAIN
TLNE E,STRFLG ;Is it a string constant?
TLNE E,SWVBT+.FXBTS+LFXBTS ;Does it not have relocation bits?
JRST GG2B ;No, something else
TLNE E,VRBLBT ;Is it a variable?
JRST GG3 ;Yes, normal
MOVSI C,(<MOVEI>) ;String constants are special
HRRZ B,E
JRST GG4
GG2B: TLNN E,NUMFLG ;IS IT A CONSTANT?
JRST GG3 ;NO, EMIT A MOVE
HRRZ B,(E) ;IS RIGHT HALF ZERO?
JUMPE B,[MOVSI C,(<MOVSI>);YES, EMIT A MOVSI
MOVS B,(E) ;ADDRESS IS VALUE OF NUMBER
JRST GG4]
HLRZ B,(E) ;IS LEFT HALF ZERO?
JUMPE B,[MOVSI C,(<MOVEI>);YES, EMIT A MOVEI
MOVE B,(E) ;ADDRESS IS VALUE OF NUMBER
JRST GG4]
GG3: MOVE B,E ;LOAD SECOND OPERAND INTO IT.
MOVSI C,(<MOVE>)
GG4: PUSHJ P,EMINST
GL2A: MOVE B,D ;PUT OTHER OP IN B.
POPJ P,
; NUMCHK - Compile time arithmetic
; NUMCHK CHECKS TO SEE IF THE TOP TWO OPERANDS ARE BOTH CONSTANT
; AND CALCULATES THEIR VALUE AT COMPILE TIME
; IT ALSO CHECKS TO MAKE SURE BOTH THINGS ARE NUMBERS!
NUMCHK: MOVE T,(OSP) ;Check first arg. for string
TLNN T,.FXBTS+LFXBTS ;Relocatable
TLNN T,STRFLG ;or not string?
JRST NUMCH2
JRST NUMERR
NUMCH2: MOVE T,-1(OSP) ;Check second argument
TLNE T,.FXBTS+LFXBTS ;Relocatable?
POPJ P, ; Yes, can't be constants
TLNE T,STRFLG ;No, better not be a string
NUMERR: ERROR <Attempt to do numeric operation on a string!>
COMMENT ⊗ You have given a string to a numeric operator, such as '+', '-',
'*', '/', '>', etc. ⊗;
MOVSI T,NUMFLG ;ARE BOTH NUMBERS?
TDNE T,(OSP) ;TOP?
TDNN T,-1(OSP) ;AND SECOND?
POPJ P, ;NO
MOVSI T,SUBSBT ;IS SECOND A SUBSCRIPT?
TDNE T,-1(OSP)
POPJ P, ;YES, BARF
POP P,(P) ;YES, DISCARD RETURN ADDRESS FOR NUMCHK
POP P,T ;ASSEMBLE INSTRUCTION IN 'T'
ADD T,[C,@(OSP)]
MOVE C,@-1(OSP) ;GET FIRST OPERAND
XCT T ;DO OPERATION
POP OSP,(OSP) ;FLUSH TOP OPERAND ONLY
; FOR UNARY OPERATORS, ENTER HERE AFTER FINDING NUMBER AND DOING OPERATION
NUMCHC: HLL T,(OSP) ;USE TOP OPERAND'S (A NUMBER) GOODBITS
HLLZ A,T ;FOR STORE NUMBER SEARCHING ROUTINE
PUSHJ P,SRHNUM ;SEARCH NUMBER BUCKET AND INSERT IF NEEDED
MOVEM A,(OSP) ;PUT IN ON THE STACK
POPJ P, ;RETURN FROM GENERATOR WHICH CALLED THIS (IT BETTER
;NOT HAVE LEFT ANYTHING ON THE STACK!!)
NUMCH1: TLNE E,STRFLG ;Is it a string?
JRST NUMERR ;Yes, lose big
TLNE E,NUMFLG ;IS IT A NUMBER?
TLNE E,SUBSBT ;AND NOT A SUBSCRIPT
POPJ P, ;NO, GIVE UP
PUSH OSP,E ;PUT IT ON THE STACK
POP P,(P) ;DISCARD NUMCH1'S RETURN ADDRESS
POP P,T ;RECOVER OPCODE
MOVE C,(E) ;GET VALUE OF CONSTANT
TRNN T,-1 ;DO WE NEED AN ADDRESS?
HRRI T,C ;YES, POINT IT TO 'C'
ADD T,[C,0]
XCT T ;NOW EXECUTE IT
JRST NUMCHC ;AND STASH THE RESULT INTO NUMBER LIST
; EMINST - Emit an instruction.
;
; EMINST IS THE INSTRUCTION EMITTING ROUTINE. CALL IT
; WITH:
; AC IN A,
; ADDRESS (+ RELOC. BITS) IN B, AND
; OPCODE IN C.
;
; IF ARRYBT IS SET, THE INDEX FIELD OF B CONTAINS THE
; INDEX INSTEAD OF THE RELOCATION BITS
;
; IF RIGHT HALF OF C IS NON-ZERO, IT IS THE
; ADDRESS OF THE APPROPRIATE BUFFER EMITTING ROUTINE
; OTHERWISE THE INSTR. IS PLACED IN THE I-TIME OR R-TIME
; BUFFERS ACCORDING TO THE STATE OF THE FLAG IN H.
EMINST: PUSH P,A ;SAVE IT.
MOVSI T2,NOSWAP ;TO TURN OFF PROTECTED BIT
HLL A,C ;ASSEMBLE INSTRUCTION IN A.
DPB A,[POINT 4,A,12] ;PUT IN AC FIELD.
HRR A,B ;ALSO ADDRESS.
TLNE B,SIACBT ;IS IT AN I-TIME AC?
ANDCAM T2,IACS(B) ;UNMARK ITS AC TABLE ENTRY
TLNE B,SRACBT ;IS IT AN R-TIME AC?
ANDCAM T2,RACS(B) ;UNMARK ITS AC TABLE ENTRY
TLZE B,FPARBT ;IS ADDR. A FORMAL PARAMETER ?
TLO A,20+RA ;YES. ADD INDIRECT BIT AND INDEX.
TLNE B,ARRYBT ;IS ADDR. A ARRAY?
JRST [ DEBUG(EMIT ARRAY REF);
AND B,[(17)] ;GET INDEX FIELD
ADD A,B ;PUT IN INDEX FIELD
HLRZ T1,B
SKIPE T1
ANDCAM T2,@[ XWD T1,IACS ;IACS(T1)
XWD T1,RACS](H) ;RELEASE APPROPRIATE AC
SETZ B, ;SET RELOCATION TO ZERO
JRST EMIN1]
HLRZS B ;PUT RELOC. BITS FOR ADDRESS IN RIGHT HALF OF B.
EMIN1: PUSH P,[EXP EMIN2] ;RETURN ADDRESS.
TRNE C,-1 ;RH OF C =0 ?
JRST (C) ;NO.
JRST @EMITB(H)
EMIN2: LDB A,[POINT 4,A,12]
MOVSI T2,NOSWAP ;TO TURN OFF PROTECTED BIT IN AC TABLE
CAIG T1,1 ;IN CASE WE WERE EMITTING TO VARIABLE AREA
ANDCAM T2,@[XWD A,RACS ;RACS(A)
XWD A,IACS](T1) ;T1 IS 1-H REVERSED!(USUALLY)
POPAJ: POP P,A ;A USEFUL ENTRY POINT.
POPJ P,
EMITB: EMICDI
EMCDI
EMITB2: EMICD
EMCD
ACTB1: XWD SIACBT+A,IACS ;PTR. TO IACS,INDEXED BY A.
XWD SRACBT+A,RACS
ACTB3: XWD D,IACS
XWD D,RACS
; GETAC - Get a free AC.
;
; GETAC SEARCHES FOR A FREE AC, EITHER I-TIME OR
; R-TIME, AS INDICATED BY THE STATE OF THE FLAG IN H.
;
; Returns AC in A. Clobbers T,T3,A,B,C
GETAC: SKIPE H ;ARE WE EMITTING R-TIME CODE ?
GETRAC: SKIPA T3,[XWD SRACBT+A,RACS] ;YES, FIND A R-TIME AC.
GETIAC: MOVE T3,[XWD SIACBT+A,IACS] ;FIND AN I-TIME AC.
MOVE A,[XWD -NACS,NFACS] ;CONSIDER ONLY AC'S 4-14
TRNE FL,CSBRBT ; ..UNLESS WE'RE COMPILING A FUNCTION..
MOVE A,[XWD -NFACS,0] ;WE ARE. CONSIDER ONLY 0-3.
HRRZM A,LASTAC# ;SAVE WHICH IS LOWEST USABLE
SKIPE @T3 ;INDIRECT ADDRESSING IS GOOD FOR YOU.
AOBJN A,.-1 ;NOT FREE. TRY FOR NEXT ONE.
HRRZ B,A
SKIPE NOTAC0 ;CAN WE USE AC ZERO?
JUMPE B,.-3 ;NO, TRY AGAIN
JUMPLE A,GETAC3 ;DID WE FIND ONE ?
PUSHJ P,GETAC2 ;NO. STORE ONE.
GETAC3: HRLI A,SRACBT ;YES. PUT IN APPROPRIATE FLAG BITS.
TLNN T3,SRACBT ;OOPS, IT'S AN I-TIME AC.
HRLI A, SIACBT
POPJ P,
GETAC2: HRRZ A,A
SUBI A,1 ;STORE HIGHEST AC.
SKIPE NOTAC0 ;CAN WE USE AC ZERO?
JUMPE A,GETAC4 ;NO, WE LOSE!
SKIPL T,@T3 ;GET VALUE AND SKIP IF SPECIALLY MARKED
JRST GSVAC+1 ;OK, WE CAN SWAP HIM OUT WITHOUT ILL EFFECTS
CAMLE A,LASTAC
JRST GETAC2+1
;THERE NO FREE AC AT ALL
GETAC4: ERROR <EXPRESSION TOO COMPLEX, MAY BE A COMPILER BUG>
GSVAC: MOVE T,@T3 ;FIND OUT WHO'S IN HIM.
TLNN T,ACFLAG ;IS IT NECESSARY TO SAVE HIM?
JRST [ SETZM @T3 ;NO, JUST FLUSH HIM
POPJ P,]
TRNN T,777760 ;IS IT AN AC?
PUSHJ P,DRYROT ;OOPS!
;**** The random good bits in VLOC have STRFLG on!!! ****
MOVE B,VLOC ;GET LOC. TO STORE HIM IN.
TLNE T,SUBSBT ;IS HE A SUBSCRIPT?
TLO B,SUBSBT ;YES, HIS STACK ENTRY BETTER SAY THAT
MOVEM B,(T) ;FIX UP HIS STACK ENTRY.
SETZM @T3 ;MARK HIM EMPTY.
MOVSI C,(<MOVEM>) ;EMIT THE STORE INST.
PUSHJ P,EMINST
PUSH P,A ;'A' WAS CLOBBERED BY EMDV!!!!
PUSHJ P,EMDV ;LEAVE A PLACE IN VARIABLES AREA.
JRST POPAJ ;RESTORE 'A' AND RETURN
;MRKAC PUTS THE AC SYMBOL IN A BACK ON THE STACK AND MARKS
; THE CORRESPONDING AC AS FULL.
MRKAC0: IOR A,MRKTAB(H) ;MARK IAC 1 OR RAC 1 FULL.
MRKAC: PUSH OSP,A ;PUT IT ON STACK.
TLNN A,SRACBT ;AN R-TIME AC?
JRST [ HRRZM OSP,IACS(A) ;NO, MARK CORRESPONDING I-TIME AC FULL.
HLLM A,IACS(A)
JRST CPOPJ]
TLO A,SIACBT ;FORCE I-TIME AC BIT
HRRZM OSP, RACS(A)
HLLM A,RACS(A)
CPOPJ: POPJ P,
;CODE TO RELEASE USED AC'S
;[Gee, i wonder what happens if A is a VLOC reference - Dec76 (TVR)]
SWAPON: PUSH P,A ;SAVE A
MOVSI T3,400000
TRNN A,777760 ;IS IT AN AC?
ANDCAM T3,@ACTB1(H)
JRST EMIN2 ;DO IT FOR AC, TOO
MRKTAB: XWD SIACBT,0 ;DESCRIPTOR FOR I-TIME AC NO. 1
XWD SRACBT,0 ;R-TIME AC 1.
; Generate Function Calls;
GAPAR: ;; HANDLE A PARAMETER WHICH IS AN ARRAY NAME.
TLNE A,ARRYBT ;IS IT AN ARRAY IDENTIFIER OR
HRR A,(A)
TLNE A,FPARBT+ARRYBT ; A FORMAL PARAMETER ?
JRST GAPR1 ;YES.
TLNE A,FOOBIT ;BETTER BE A FOO-SYMBOL, THEN....
TRZN A,400000 ;FURTHERMORE, IT MUST BE A P-SYM.
ERROR <IMPROPER ARRAY PARAMETER>
;Code generated (in I-Time) for P-array as argument to function
; MOVE AC,PBASE+n
; CAMG AC,[XWD INSXR,777777]
; CAMG AC,[XWD INSXR,0]
; PUSHJ P,BADARR
; MOVEM AC,[calling seq.]
;
GSPA2: PUSH P,A ;SAVE P NO.
PUSHJ P,GETIAC ;FIND FREE I-TIME AC.
POP P,B
ADDI B,PBASE ;CALC. ADDR. OF P-SYMBOL.
MOVE C,[MOVE EMICDI] ;EMIT MOVE AC,P-SYMBOL TO THE
PUSHJ P,EMINST ;I-TIME CODE STREAM.
;Here is code to check to make sure its an array!
PUSH P,A ;Save AC
MOVEI B,[XWD INSXR+1,777777] ;Do bounds checking at I-time
MOVE C,[CAMG EMICDI] ;Emit CAMG AC,[777777(INSXR)]
PUSHJ P,EMINST
MOVEI B,[XWD INSXR,0] ;Do bounds checking at I-time
MOVE C,[CAMG EMICDI] ;Emit CAMG AC,[0(INSXR)]
PUSHJ P,EMINST
MOVE A,[PUSHJ P,BADARR]
SETZ B,
PUSHJ P,EMICDI ;EMIT ERROR CALL
POP P,A ;Restore AC
HRLI A,(<MOVEM>) ;NOW A MOVEM AC, INTO THE PARAMETER
DPB A,[POINT 4,A,12] ;LOCATION.
TRZA A,-1 ;CLEAR ADDRESS FIELD.
GDPAR: MOVSI A,(<SETZM>) ;PARAM. LIST AT I-TIME.
PUSH OSP,ILOC ;PUT ARRAY MARKER IN OPERAND
MOVSI T,ARRYBT+FPARBT ;STACK SO A FIXUP CAN BE EMITTED TO
IORM T,(OSP) ;THE UPCOMMING HRRM WHEN THE PARAMETERS
MOVEI B,0 ;[NO RELOCATION, PLEASE.]
JRST EMICDI ;EMIT HRRM TO STORE ARRAY LOC. INTO
;PARAMETER CELL, AND RETURN.
GAPR1: PUSH OSP,A ;PLACE IN OPERAND STACK.
TLNE A,FPARBT ;CHECK TO FIND BUGS, MAKE SURE FORMAL
TRNN FL,INSDEF ;PARAMETER AREN'T USED IN INSTRUMENTS!
POPJ P, ;OK, RETURN
PUSHJ P,DRYROT ;OOPS!
GSPAR: ;;HANDLE A PARAMETER WHICH IS A STRING
TLNE A,FPARBT!VRBLBT ;IS IT A FORMAL PARAMETER OR VARIABLE?
HRR A,(A) ;YES, GET NUMBER OF PARAMETER OR ADDRESS
TLNE A,VRBLBT ;Is it a string variable?
TLO A,20 ; Yes, turn on indirect bit
TLZE A,STRFLG ;IS IT A STRING?
JRST GAPR1
TLNE A,FOOBIT ;BETTER BE A FOO-SYMBOL
TRZN A,400000 ;AND A P-SYMBOL
ERROR <IMPROPER STRING PARAMETER>
JRST GSPA2 ;WILL THAT REALLY WORK???
; More Code Generator for Function Calls (GFUNC)
; (Rewritten 25 Sep 76 by TVR)
GFUNC: MOVE A,@-3(P) ;PICK UP THE CALLING INSTRUCTION FOR THE FUNCTION.
MOVE D,RLOC ;DECIDE WHETHER CALL IS TO BE IN
MOVEI H,0 ;R-TIME OR I-TIME CODE.
SKIPE IONLY ;ARE WE GENERATING I-TIME ONLY?
JRST GFUNC8 ;YES
TLZN A,20 ;IND. BIT IN INSTR. SAYS R-TIME ALWAYS.
CAME D,-4(P) ;ALSO R-TIME IF ANY R-TIME PARAMETERS
MOVEI H,1 ;HAVE BEEN COMPILED.
GFUNC8: PUSH P,-1(P) ;PUT PAR. COUNT ON STACK.
HRRZM P,TEMP1# ;SAVE LOC. OF COUNT.
GFUNC5: SOSGE @TEMP1 ;MORE PARAMS ?
JRST GFUNC4 ;NO.
PUSHJ P,GMURK1 ;GET A PARAM.
TLNE E,FPARBT ;IS IT A FORMAL PARAMETER ?
JRST GFUNC7 ;YES
TLNE E,ARRYBT ;IS IT AN ARRAY?
JRST GFUNC9 ;DO ARRAY REFERENCE
TLNE E,SRACBT+SIACBT ;Is it an AC?
JRST GFUN13 ; Yes, save it perhaps
;AN ORDINARY TYPE PARAMETER
GFUN11: PUSH P,E ;SAVE IT.
JRST GFUNC5 ;GET ANOTHER.
;An AC, make it so that AC will get saved!
GFUN13: PUSH P,E
TLNE E,SRACBT ;An R-time AC?
JRST [MOVEM E,ACS(E) ;Yes, make pointer into stack
HRRM P,ACS(E)
JRST GFUNC5]
MOVEM E,IACS(E) ;Must be an I-time AC
HRRM P,IACS(E)
JRST GFUNC5
;HANDLE AN ARRAY PARAMETER
GFUNC9: LDB A,[POINT 4,E,17] ;IS IT SUBSCRIPTED?
JUMPE A,GFUN11 ;NO, WE DON'T CALCULATE SUBSCRIPT
SETZ A, ;IT'S AN SUBSCRIPTED ARRAY, EMIT
MOVE B,E ;CODE TO GET ADDRESS REFERNCED
MOVSI C,(<MOVEI>)
PUSHJ P,EMINST
JRST GFUN10 ;AND PUT IT INTO CALLING SEQUENCE
;HANDLE A FORMAL PARAMETER
GFUNC7: TRNE FL,INSDEF ;IF THIS IS AN INSTRUMENT DEFINITION, IT REALLY
JRST GFUN12 ;MEANS WE WANT TO FIX UP A UNIT GENERATOR CALL!!!
MOVE A,E ;SIGH. THE PRICE OF HONESTY ...
HRLI A,(<MOVE (RA)>) ;EMIT CODE TO PICK UP THE
MOVEI B,0 ;PARAM. PTR. AND PUT IT IN THE
PUSHJ P,@EMITB(H) ;CURRENT CALLING SEQUENCE.
;PUT SOMETHING INTO CALLING SEQUENCE
GFUN10: MOVE E,ILOC(H) ;SAVE ILOC OR RLOC FOR LATER FIXUP.
TLO E,FPARBT ;MIGHT AS WELL USE THIS BIT...
MOVSI A,(<MOVEM>) ;NOW THE SECOND INSTR....
PUSHJ P,@EMITB(H)
PUSHJ P,SWAPON ;TURN OFF NOSWAP BIT
JRST GFUN11
GFUN12: TLNE E,ARRYBT ;BETTER BE AN ARRAY...
JRST GFUN11 ;IT IS.
PUSHJ P,DRYROT ;OOPS!
GFUNC4: MOVE T3,ACTB1(H) ;Pick appropriate set of AC's to save
MOVSI A,-NFACS ;PREPARE TO SEARCH AC'S 0-4.
SKIPN T,@T3 ;IS THIS ONE IN USE ?
AOBJN A,.-1 ;NO.
JUMPG A,GFUNC6 ;DID WE FIND A BUSY ONE ?
PUSHJ P,GSVAC ;YES. SAVE IT.
JRST GFUNC4
;NOW EMIT THE CALLING INSTR.
GFUNC6: POP OSP,A ;EMIT CALLING INSTRUCTION
LDB B,[POINT 4,A,17] ;RELOC. BITS.
TLZ A,37
PUSHJ P,@EMITB(H) ;
GFUN15: POP P,A ;GET PARAM. FROM STACK.
JUMPL A,CPOPJ ;IF IT'S THE MARK, RETURN.
TLZE A,FPARBT ;IS IT A FORMAL PARAMETER ?
JRST GFUN14 ; Yes, handle specially
TLNE A,SIACBT ;An I-time AC?
JUMPN H,[
WARN <Please MAIL LCS a message saying GFUN15 executed>
COMMENT ⊗ There was some question as if a compiler bug was fixed. ⊗;
PUSH OSP,A ;Put AC back on stack and make GMURK1
PUSHJ P,GMURK1 ;save it
MOVE A,E ;Now, prepare to put saved copy into
JRST GFUNC2 ] ;calling sequence
GFUNC2: LDB B,[POINT 4,A,17] ;RELOC. BITS.
TLZ A,37
TLZE A,ARRYBT ;IS IT AN ARRAY NAME ?
TLO A,INSXR ;YES. ADD INDEX FIELD.
GFUNC3: PUSHJ P,@EMITB(H) ;
PUSHJ P,SWAPON ;TURN OFF NOSWAP BIT
TLNE A,SIACBT ;I-Time AC?
SETZM IACS(A) ; Yes, forget we were using it (otherwise,
; it still points into PDL, which is then
; gets clobbered when GETAC is called. (This
; someday should be done in a better way)
TLNE A,SRACBT ;R-Time AC?
SETZM RACS(A) ; Yes, forget we were using it (see above)
JRST GFUN15 ;Do next argument
GFUN14: MOVEI B,.FXBTS ;YES. EMIT A FIXUP TO THE RIGHT INSTRUCTION.
TLZ A,400000+LRFXBT+SWAPBT ;A REPLACEMENT FIXUP TO RT. HALF.
TLO A,RRFXBT
PUSHJ P,@EMITB2(H) ;EMIT IT TO I-TIME OR R-TIME BUFER.
MOVEI B,0 ;NOW RESERVE SPACE FOR THE PARAM.
JRST GFUNC3
SUBTTL Unit Generator Call
; A UNIT GENERATOR CALL IS IN TWO PART, THE FIRST (WHICH IS OPTIONAL
; INITIALIZES THE UNIT GENERATOR AT I-TIME AND THE SECOND WHICH IS
; THE R-TIME CALL. THE SECOND PART LOOKS EXACTLY LIKE AN ORDINARY
; FUNCTION CALL AND THE FIRST PART GETS AS A ARGUMENT A POINTER TO
; THE END+1 OF THE R-TIME PART OF THE UNIT GENERATOR CALL. IT
; SHOULD KNOW WHERE TO GET THE ARGUMENTS IT NEEDS FROM THE R-TIME
; CALL
;
;;I-TIME code
; <I-time calling instruction>
; G0001
;
;;R-TIME code
; <R-time calling instruction>
; <arguments>
;G0001←←.+1
;IFE UGEXPF, < MOVEM RET,Un >
;
;
UGCALL: SKIPE IONLY
WARN(Attempt to call unit generator at I-Time)
COMMENT ⊗ Unit generators always run at least partially in R-Time.
What has probably happened was that this unit generator call somehow
managed to find its way inside an ≤I_ONLY≥ statement, which can easily
happen if you leave out an ≤END≥ from the construct ≤I_ONLY BEGIN...≥ ⊗;
PUSH P,CINST1 ;SAVE OLD COPY FOR RECURSION
DEBUG (UNIT GENERATOR CALL)
HRRZM A,CINST1# ;SAVE IT.
PUSHJ P,SCAN ;PEEK AT NEXT THING.
CAMN A,CTBL+"[" ;IS IT A [ ?
JRST GUG1 ;YES. UNIT GEN. HAS CONTROLLED CALLING RATE.
MOVEM A,SNCHR ;NO, IT'S PROBABLY THE (. PUT IT BACK WHERE
;SCAN WILL SEE IT AGAIN.
PUSHJ P,GUGCALL ;GENERATE TO UNIT GENERATOR CALL
POP P,CINST1 ;RESTORE OLD COPY
POPJ P, ;RETURN
;GENERATE UNIT GENERATOR CALL
GUGCALL: MOVE A,CINST1 ;RECOVER POINTER FOR USE OF FUNCAL.
PUSHJ P,FUNCA2 ;COMPILE CALL ON THE UNIT GEN.
PUSH P,A ;REMEMBER AC CONTAINING OUTPUT
SKIPE UGEXPF ;IS IT WITHIN AN EXPRESSION?
JRST GUGCA2 ;YES, DON'T MAKE AN U-SYMBOL FOR IT
MOVE B,VLOC ;NO, GET LOC. FOR OUTPUT OF UNIT GEN.
AOS C,UOPTR ;NO, INCREMENT COUNT OF UNIT GENS.
TLO B,RVBT ;IS THIS NEEDED??
MOVEM B,UOTBL(C) ;ENTER OUTPUT LOC. IN TABLE.
MOVE C,[MOVEM EMCDI] ;EMIT STORE INSTRUCTION TO
PUSHJ P,EMINST ;PUT OUTPUT OF UNIT GEN. AWAY.
PUSHJ P,EMDV ;MAKE ROOM IN VARIABLES AREA FOR IT.
GUGCA2: MOVE T,@CINST1 ;RETRIEVE PTR. TO RANDOM GOOD BITS.
SKIPN A,-1(T) ;DOES UNIT GEN. HAVE I-TIME CODE?
JRST GUGCA3 ;NO.
PUSHJ P,EMIABS ;YUP. EMIT THE CALLING INSTR.
HRRZ A,RLOC ;AS PARAMETER, GIVE IT A PTR. TO
SKIPE UGEXPF ;(IS THIS CALL WITHIN AN EXPRESSION?
ADDI A,1 ; YES, ACCOUNT FOR THE MISSING 'MOVEM')
MOVEI B,RRELBT ;JUST AFTER THE MOVEM EMITTED
PUSHJ P,EMICDI ;ABOVE.
GUGCA3: POP P,A ;GET BACK AC TO RETURN VALUE
POPJ P,
; IF THE NAME OF A UNIT GENERATOR IS FOLLOWED BY AN EXPRESSION
; IN SQUARE BRACKETS, THE U.G. GETS CALLED ONLY EVERY N TIME
; STEPS, WHERE N IS THE VALUE OF THE EXPRESSION.
; N IS RECALCULATED EVERY TIME THE U.G. IS CALLED.
;;I-TIME code
; SETZM TMP001
; <I-time calling instruction>
; G0001
;
;;R-TIME code
; AOSGE TMP001
; JRST G0001
; <expression>
; MOVEM AC,TMP001
; <R-time calling instruction>
; <arguments>
;IFE UGEXPF,< MOVEM RET,Un >
;IFN UGEXPF,< MOVEM RET,TMP002
;G0001:
;IFN UGEXPF,< MOVE RET,TMP002 >
;
GUG1: MOVE C,[AOSGE EMCDI] ;INSTR. TO COUNT NO. OF TIME STEPS TO SKIP THIS UG.
MOVE B,VLOC ;GRAB LOCATION IN VARIABLE AREA TO HOLD COUNT OF TIME STEPS TO SKIP.
MOVEI A,0 ;NO AC FIELD, PLEASE.
PUSHJ P,EMINST ;EMIT THE AOSGE JUST AHEAD OF THE CODE TO CALL THE U.G.
MOVE C,[SETZM EMICDI] ;ALSO EMIT AN INSTR. TO THE I-TIME
MOVE B,VLOC ;CODE TO INIT. THE COUNTER LOCATION TO 0 (SO U.G. GETS CALLED FIRST TIME).
PUSHJ P,EMINST
PUSH P,RLOC ;SAVE R-TIME LOC. COUNTER (FOR LATER FIXUP TO JRST WE ARE ABOUT TO EMIT).
PUSH P,VLOC ;ALSO VARIABLE LOC., FOR LATER LOADING OF THE STEPS-TO-SKIP COUNTER.
PUSHJ P,EMDV ;MAKE A WORD FOR IT.
MOVSI A,(<JRST>) ;NOW EMIT THE JUMP AROUND THE CALL OF
PUSHJ P,EMCDI ;THE U.G. !!"" N.B.: B IS 0 HERE FROM CALL ON EMDV !!
PUSHJ P,SEXPR ;NOW COMPILE THE EXPRESSION IN THE BRACKETS.
CAME A,CTBL+"]" ;SHOULD BE FOLLOWED BY ONE...
WARN <Missing ']' in unit generator call>
MOVEI H,1 ;INDICATE THAT WE ARE WORKING WITH R-TIME CODE...
PUSHJ P,GMURK1 ;..AND GET EXPR OFF OPERAND STACK.
PUSHJ P,GG2 ;NOW GET IT INTO AN AC.
IFE KI10SW,<
MOVSI C,(<KAFIX>) ;EMIT INSTR. TO FIX VALUE OF EXPRESSION.
MOVEI B,233000 ;MAGIC NO. FOR ADDRESS OF FIX, HO HO.
>;IFE KI10SW
IFN KI10SW,<
MOVSI C,(<KIFIX>) ;EMIT INSTR. TO FIX VALUE OF EXPRESSION.
MOVE B,A ;Address is same as AC to get same effect.
>;IFN KI10SW ;as KA10 FIX
PUSHJ P,EMINST
POP P,B ;GET LOCATION IN VARIABLE AREA OF THE STEPS-TO-SKIP COUNTER.
MOVSI C,(<MOVNM>) ;AND EMIT INSTR. TO STORE NEGATIVE OF COUNT THERE.
PUSHJ P,EMINST
PUSHJ P,GUGCALL ;NOW GENERATE CALL ON UNIT GENERATOR.
POP P,UGTMP# ;PUT LOC. OF THE JRST UNDER THE AOSGE SOMEWHERE SAFE
SKIPN UGEXPF ;IS IT WITHIN AN EXPRESSION?
JRST GUG1A ;NO
MOVE B,VLOC ;YES, SAVE SOME SPACE TO KEEP IT
PUSH P,A ;REMEMBER AC CONTAINING OUTPUT
PUSH P,B ;REMEMBER TMP. VAR. SOMEWHERE
MOVE C,[MOVEM EMCDI]
PUSHJ P,EMINST ;SAVE OUTPUT SOMEWHERE
PUSHJ P,EMDV ;THIS MUNGS 'B'
GUG1A: MOVE A,UGTMP ;GET ADDRESS OF JRST UNDER THE AOSGE
MOVEI B,.FXBTS ;EMIT FIXUP TO MAKE IT POINT HERE (I.E. AFTER
PUSHJ P,EMCD ; END OF U.G. CALL)
SKIPN UGEXPF ;WITHIN AN EXPRESSION?
JRST GUG1B ;NO
MOVE C,[MOVE EMCDI]
POP P,B ;EMIT CODE TO PICK UP OUTPUT
POP P,A
PUSHJ P,EMINST
GUG1B: POP P,CINST1 ;RESTORE OLD COPY OF CINST1 AND
POPJ P, ;RETURN
SUBTTL Enter Item into Symbol Table
;; UTILITY ROUTINE TO ENTER AN ITEM IN THE MAIN SYMBOL TAB.
GETNAM: PUSHJ P,SCANV ;SCAN AN IDENTIFIER.
GETNM1: AOS T,(P) ;TO SKIP PARAM ON RETURN.
JUMPE A,GNM2 ;SHOULD BE UNDEFINED...
TLOE A,DF ;IT'S NOT. MAYBE IT'S A DELIMITER ?
ERROR (Missing IDENTIFIER)
SKIPE BLEVEL ;IS IT WITHIN A BEGIN-END
JRST GNM2 ;YES, THEN DON'T MESS AROUND!
; TLNN A,@-1(T) ;NO. MAYBE ALREADY RIGHT TYPE ? *** BAGBITING DWP CODE
HLRZ B,(A) ;GET ORGINAL GOODBITS INTO RH
CAIE B,@-1(T) ;THIS COMPARES WITH ADDRESS (INSTEAD OF
; CONTENTS, AS CAME B,-1(T))
SKWARN (Multiply defined symboi)
JRST GNM2 ;ENTER NEW COPY OF SYMBOL
SKIPGE -1(T) ;AH, IT IS. SHOULD WE REENTER IT ?
POPJ P, ;NO. ITS OLD ENTRY WILL DO.
GNM2: HRLZ A,-1(T) ;YES. GET TYPE BITS.
AENTER: LDB T,[POINT 6,ACCUM,5] ;GET CHARACTER COUNT
IDIVI T,6 ;NUMBER OF WORDS - 1
ADDI T,3 ;PLUS 1+GOODBITS WORD+LINK
PUSHJ P,GPS ;GET A BLOCK TO HOLD IT
MOVE T
; HRRZ JOBFF ;GET NEXT FREE LOCATION. *****
HRRZ B,CBNO ;GET BUCKET NO. OF THING JUST SCANNED.
EXCH BUCTBL(B) ;UPDATE BUCKET HEAD.
; AOS B,JOBFF ;*****
AOS B,T
MOVEM -1(B) ;PUT THE LINK IN THE NEW ENTRY.
MOVEM A,1(B) ;PUT THE RANDOM GOOD BITS IN.
MOVE ACCUM ;GET FIRST WORD OF NAME.
MOVEM (B) ;PUT IN TABLE.
AOS B,T
; AOS B,JOBFF ;*****
MOVEI T2,ACCUM+1;PREPARE TO MOVE REST OF NAME.
AEL1: AOS T
; AOS JOBFF ;*****
SKIPN T1,(T2) ;ANY MORE OF THE NAME ?
JRST AEL2 ;NO.
MOVEM T1,(T) ;YES. PUT IN TABLE. *****
CAIL T2,ACCUM+2 ;UNLESS FIRST OR SECOND WORD,
SETZM (T2) ;ZERO WORD IN ACCUM.
AOJA T2,AEL1
AEL2:
HRR A,B
; HRRZ JOBFF ;*****
; HRLM JOBSA ;*****
POPJ P,
SUBTTL Declarations
;Variable declaration
EXTERNAL JOBDDT,JOBREL
;<VARIABLE DECLARATION> ::= VARIABLE <VAR. DEC. LIST>
;<VAR. DEC. LIST> ::= <VAR. DEC.>|<VAR. DEC. LIST>|<DEC. DEC.>
;<VAR. DEC.> ::= <IDENTIFIER>|/<IDENTIFIER>
DVRBL1: CAME A,COMMAV ;IS IT A COMMA ?
POPJ P, ;NO. END OF DECL.
DVRBL: PUSHJ P,SCAN ;GET NEXT ITEM.
CAMN A,CTBL+"/" ;IS IT A "/" ?
JRST DVRBL2 ;YES. DEFINE FOLLOWING VARIABLE AS R-TIME.
PUSHJ P,GETNM1 ;NO. MUST BE NAME OF VARIABLE. PUT IN SYM. TABLE.
XWD 400000,VRBLBT ;PARAM. TO GETNM1.
DVRBL4: JUMPL A,DVRBL3 ;WAS IT ALREADY DEFINED ?
MOVEI T,1
PUSHJ P,GPS ;GET A WORD
; AOS A,JOBFF ;NO, IT'S NEW. LEAVE WORD FOR THE VALUE. *****
; SUBI A,1 ;GET PTR. TO THAT WORD.
HRRM T,(B) ;PUT IN GOOD BITS WORD (NO REL. BITS).
DVRBL3: PUSHJ P,SCAN ;GET COMMA OR SEMICOLON.
JRST DVRBL1 ;BACK FOR MORE.
DVRBL2: PUSHJ P,GETNAM ;SCAN AND ENTER NAME OF VARIABLE.
XWD 400000,VRBLBT!RVBT ;INCLUDE 'R-TIME' BIT.
JRST DVRBL4
.UG: ERROR<Unit Generators must be external>
COMMENT ⊗ Should be preceded with the symbol EXTERNAL. External unit generators
are written with FAIL or MACRO and loaded with the Music Compiler. ⊗;
UGDEF: PUSHJ P,GETNAM ;Get & set name of Unit Generator
XWD 400000,UGBIT
PUSH P,B
PUSHJ P,[PUSHJ P,SYMSCH ;FIND STARTING ADDRESS.
ERROR (Missing External function)
COMMENT ⊗ Either an external function was not loaded or its name was misspelled.⊗;
POPJ P,]
POP P,B
MOVEI A,@-2(A) ;Parameters are located on back from unit generator itself
HRRM A,(B) ;Set address of unit generator
PUSHJ P,SCAN
CAMN A,COMMAV ;Another item?
JRST UGDEF ; Yes, define it, too
POPJ P, ;No, return
NXFUN: 0
ERROR (Missing External function)
COMMENT ⊗ Either an external function was not loaded or its name was misspelled.⊗;
JRST NXFUN+1
; Function declaration
DF5: CAME A,COMMAV ;ARE THERE MORE DEFINITIONS ?
POPJ P, ;NO.
DFUNC: TRO FL,CSBRBT+SFOOBT ;ENTER FUNCTION DEFINING MODE.
DEBUG (FUNCTION DEFINTION)
PUSHJ P,GETNAM ;GET FUNCTION NAME.
EXP FUNBIT ;PARAMETER TO GETNAM.
PUSH P,A ;SAVE NAME
; PUSH P,BUCTBL ;####$$%%$ A TEMPORARY KLUGE !!
JSR PUSHBUCKBL ;SAVE SYMBOL TABLE POINTERS
PUSH P,RETFIX ;SAVE FIXUP WORD
SETZM RETFIX
MOVEI T,5
PUSHJ P,GPS ;GET A 5 WORD BLOCK
MOVE A,T ;(FOR COMPATABLITY)
; MOVE A,JOBFF ;GET FIRST FREE STORAGE LOC. *****
HRRM A,(B) ;MAKE GOOD BITS WORD POINT THERE.
HRLI A,600 ;MAKE A INTO A BYTE POINTER.
PUSH P,A
PUSH P,A
IBP (P) ;THIS POINTER IS FOR PARAMETER DESCRIPTORS.
HRLI A,400000+LRFXBT+RRFXBT ;NOW EMIT FIXUP TO THE
;LOCATION IN THE SYM. TABLE WHICH WILL
MOVEI B,.FXBTS ;CONTAIN THE CALLING INSTR. FOR THE
;FUNCTION, SO IT CAN BE UPDATED AT
PUSHJ P,EMICD ;LOAD TIME WITH THE RELOCATED ADDRESS OF THE FUNCTION.
; ADDI A,5 ;LEAVE ENOUGH ROOM FOR 22 PARAMETER
; HRRZM A,JOBFF ;DESCRIPTORS. *****
TRNN FL,EXTFLG ;IS IT AN EXTERNAL FUNCTION ?
SKIPA A,ILOC ;NO. ADDRESS IS IN ILOC.
PUSHJ P,[PUSHJ P,SYMSCH ;YES. FIND STARTING ADDRESS.
ERROR (Missing External function)
COMMENT ⊗ Either an external function was not loaded or its name was misspelled.⊗;
POPJ P,]
TLO A,(<JSA RA,>) ;MAKE INTO A CALLING INSTR.
MOVEM A,@-1(P) ;PLACE IN SYM. TABLE.
LDB B,[POINT 4,A,17] ;GET THE RELOCATION BITS.
TLZ A,17 ;TURN THEM OFF IN THE INSTRUCTION WORD.
PUSHJ P,EMICD ;EMIT AS VALUE OF ABOVE FIXUP.
PUSH P,[-1] ;INIT. THE PARAMETER COUNT.
PUSHJ P,SCAN ;LOOK AT NEXT THING.
CAME A,LPARV ;A ( ?
JRST DFNOPR ;NO. THERE ARE NO PARAMETERS.
DF2: PUSHJ P,SCAN ;SCAN A PARAMETER.
CAMN A,STRV ;IS IT A STRING PARAMETER?
JRST [ PUSHJ P,DFGSYM ;YES, GET AN IDENTIFIER
HRLI A,FPARBT!STRFLG ;SET STRING BITS
PUSHJ P,AENTER ;ENTER SYMBOL INTO TABLE
MOVEI STRPAR ;THE TYPE OF PARAMETER
JRST DF2B] ;PUT IN INTO FUNCTION DESCRIPTOR
CAMN A,ARRV ;IS IT A ARRAY PARAMETER?
JRST [ PUSHJ P,DFGSYM ;YES, GET AN IDENTIFIER
HRLI A,FPARBT!ARRYBT ;SET ARRAY BITS
PUSHJ P,AENTER ;ENTER SYMBOL INTO TABLE
MOVEI ARRPAR ;THE TYPE OF PARAMETER
JRST DF2B] ;PUT IN INTO FUNCTION DESCRIPTOR
CAMN A,INTGV ;IS IT A INTEGER PARAMETER?
JRST [ TRNN FL,EXTFLG ;YES, IS IT AN EXTERNAL FUNCTION?
ERROR <INTEGERS PRESENTLY ALLOWED ONLY FOR EXTERNAL FUNCTIONS, SORRY>
PUSHJ P,DFGSYM ;MAKE SURE IT'S A GOOD IDENTIFIER
HRLI A,FPARBT!VRBLBT!FIXFLG ;SET BITS FOR INTEGER
PUSHJ P,AENTER ;ENTER SYMBOL INTO TABLE
MOVEI INTPAR ;THE TYPE OF PARAMETER
JRST DF2B] ;PUT IN INTO FUNCTION DESCRIPTOR
; More Function Declaration
DF2A: PUSHJ P,DFGSY2 ;MAKE SURE IT'S A VALID IDENTIFIER
HRLI A,FPARBT!VRBLBT ;MAKE A INTO FORMAL PARAM. INDICATOR
; TRNE FL,ARRFLG
; HRLI A,FPARBT!ARRYBT ;IF IT'S AN ARRAY
PUSHJ P,AENTER ; AND ENTER THE SYMBOL.
MOVEI VARPAR ;PUT 'ORDINARY' FLAG IN THE PARAMETER
; TRZE FL,ARRFLG ;AN ARRAY NAME PARAM. ?
; MOVEI ARRPAR ;YES. USE RIGHT DESCRIPTOR BIT.
DF2B: IDPB -1(P) ;DESCRIPTOR FOR THIS PARAM.
PUSHJ P,SCAN
CAMN A,COMMAV ;A COMMA ?
JRST DF2 ;YES LOOK FOR MORE PARAMETERS.
CAME A,RPARV ;IT BETTER BE A ).
ERROR <Missing ')' in function definition>
PUSHJ P,SCAN ;GET THE =.
MOVEI B,0 ;FLAG END OF PARAMETER DESCRIPTORS.
IDPB B,-1(P)
DFNOPR: TRNE FL,EXTFLG ;IS THIS AN EXTERNAL FUNCTION ?
JRST DF4 ;YES. LOOK FOR NO DEFINITION.
PUSH P,IONLY ;SAVE STATE OF IONLY FLAG
SETOM IONLY
CAMN A,SEMICV ;IS IT THE LONG FORM?
JRST DFLONG ;YES, BETTER BE A BLOCK
CAMN A,CTBL+"=" ;NO, MUST BE A '=` OR '←`
JRST .+3
CAME A,LARV
ERROR <Missing ';' or '=' in function definition>
PUSHJ P,EMICDI ;LEAVE ROOM FOR THE JSA WORD.
TRZ FL,SFOOBT ;LET SCANNER SEE FOO-SYMBOLS AGAIN.
PUSHJ P,SEXPR ;SCAN AN EXPRESSION.
POP P,IONLY ;RESTORE I-ONLY FLAG
JRST DF4
DFLONG: PUSHJ P,EMICDI ;LEAVE ROOM FOR THE JSA WORD.
TRZ FL,SFOOBT ;LET SCANNER SEE FOO-SYMBOLS AGAIN.
PUSHJ P,SCAN ;BETTER BE A 'BEGIN'
CAME A,BEGINV
ERROR <Missing 'BEGIN' in function definition>
PUSHJ P,CBLOCK ;COMPILE A BLOCK
PUSH P,A
SKIPN A,RETFIX ;ANY RETURN STATEMENTS?
JRST DF4B ;NO
TLO A,CHAINBT ;A CHAIN FIXUP
MOVEI B,.FXBTS
PUSHJ P,EMICD
DF4B: POP P,IONLY ;RESTORE I-ONLY FLAG
JRST DF4A
DF4: PUSH P,A
TRNE FL,EXTFLG ;AN EXTERNAL ?
DF4A: SKIPA E,[XWD SIACBT,0] ;YES. RESULT ALWAYS IN 0.
PUSHJ P,GMURK1 ;GET IT OFF STACK.
PUSHJ P,GG2 ;MAKE SURE ITS IN AN AC.
IDPB A,-2(P) ;TELL UNIVERSE WHICH AC .
AOS B,-1(P) ;ADJUST PARAMETER COUNT.
IDPB B,-3(P) ;PUT IN SYM. TABLE.
MOVEI A,RA ;EMIT RETURN INSTR.
MOVSI C,(<JRA RA,(RA)>)
TRNN FL,EXTFLG ;...UNLESS THIS IS AN EXTERNAL.
PUSHJ P,EMINST
AOS A,-2(P) ;FIND TOP OF PARAM. DESC. STRING.
; HRRZM A,JOBFF ;RESET FREE STORAGE. *****
; HRLM A,JOBSA ;*****
POP P,A
SUB P,[XWD 3,3] ;FORGET JUNK IN STACK.
; POP P,BUCTBL ;##$$%$# MORE OF THAT KLUGE !!!
POP P,RETFIX ;RESTORE FIXUP WORD
JSR POPBUCTBL ;RESTORE SYMBOL TABLE POINTERS
EXCH A,(P) ;SAVE SCANNED SYMBOL AND GET NAME
PUSHJ P,DCLMSG ;PRINT MESSAGE
JUMP [ASCIZ/FUNCTION - /]
POP P,A ;RESTORE SCANNED SYMBOL
TRZ FL,CSBRBT+SFOOBT ;LEAVE FUNCTION DEFINING MODE.
JRST DF5 ;ALL DONE.
DFGSYM: PUSHJ P,SCAN
DFGSY2: TLNE A,DF+NUMFLG ;GET A SYMBOL AND CHECK FOR VALID IDENTIFY
WARN <ILLEGAL FORMAL PARAMETER>
AOS A,-1(P) ;INCREMENT PARAMETER COUNT.
POPJ P,
; Instrument Declaration
;; MORE SYNTAX ANALYZER. COMPILE AN INSTRUMENT DEFINITION.
CINS: TRON FL,INSDEF ;ARE WE INSIDE AN INSTRUMENT DEFINITION
SKIPE BLEVEL ;OR BLOCK
ERROR (Missing 'END')
PUSHJ P,GETNAM ;GET NAME OF INSTRUMENT.
EXP INSBIT ;PARAMETER TO GETNAM.
PUSH P,A ;SAVE NAME
MOVEI T,1 ;GET A WORD
PUSHJ P,GPS
MOVE A,T ;(FOR COMPATABILITY)
; AOS A,JOBFF ;GET PLACE FOR MORE GOOD BITS.. *****
; SUBI A,1
HRRM A,(B) ;MAKE RANDOM BITS WORD POINT THERE.
HRLI A,RRFXBT ;RIGHT HALF REPLACEMENT TYPE FIXUP.
MOVEI B,.FXBTS ;EMIT FIXUP TO RIGHT HALF FROM
PUSHJ P,EMICD ;FIRST LOC. OF I-TIME CODE.
HRLI A,LRFXBT+SWAPBT ;FIXUP TO LEFT HALF FROM FIRST LOC.
PUSHJ P,EMCD ;OF R-TIME CODE.
;CINS5: PUSHJ P,SCAN
;CINS3: PUSHJ P,SMCS1 ;IGNORE SEMICOLON, IF ANY.
; CAMN A,ENDV ;IS IT AN END ?
; JRST CINSE ;YES.
; TLNE A,UGBIT ;IS IT A UNIT GENERATOR CALL ?
; JRST [ PUSHJ P,UGCALL
; JRST CINS5] ;BACK FOR MORE.
;CINS4: PUSHJ P,STAT ;ITS NOT A UNIT GEN. CALL.
; JRST CINS3 ;NO
PUSHJ P,CBLOCK
EXCH A,(P) ;SAVE SCANNED SYMBOL AND GET BACK NAME
PUSH P,A ;SAVE IT TOO
CINSE: SETZM IARR1 ;YES. ZERO THINGS.
MOVE [XWD IARR1,IARR1+1]
BLT IARR2-1
SETOM IARR1 ;SET THESE TO -1
MOVE [XWD IARR2,IARR2+1]
BLT IARR5-1
SETZM IARR4 ;YES. ZERO THINGS.
MOVE [XWD IARR4,IARR4+1]
BLT IARR3-1
MOVE A,[POPJ P,] ;PUT RETURN INSTR. AT END OF
MOVEI B,0 ;THE I-TIME CODE.
PUSHJ P,EMICDI
PUSHJ P,EMCDI ;ALSO THE R-TIME CODE.
CINSR1: POP P,A ;RECOVER NAME
PUSHJ P,DCLMSG ;PRINT MESSAGE
JUMP [ASCIZ/INSTRUMENT - /]
; PUSHJ P,SCAN
POP P,A ;RESTORE SCANNED SYMBOL
TRZ FL,INSDEF ;CHANGE THIS LATER ****
POPJ P,
; Array Definition
;NO MORE SHALL THIS CODE GET ILL MEM REFS!!!!
COMMENT ⊗ Symbol table format for array
<link to next symbol>
<length, first 5 characters>
<goodbits>,,<array address>
<symbol table entry>
FOO.(INSXR)
<length>
FOO.: BLOCK <length>
⊗;
DARR: PUSH P,[0] ;DEFINE SOME ARRAYS.
DARR1: PUSHJ P,GETNAM ;SCAN NAME.
XWD DF,ARRYBT ;TYPE PARAMETER TO GETNAM.
DEBUG (ARRAY DEF)
PUSH P,A ;STACK PTR. TO ENTRY.
PUSHJ P,SCAN ;LOOK FOR COMMA OR '(' OR '['
CAME A,LPARV ;Can be a (.
CAMN A,LFTBRK ;or a [
JRST DARR1A
CAMN A,COMMAV ;Else must be a ','.
JRST DARR1 ;YES. GET MORE NAMES.
ERROR <Missing '(' in array declaration>
DARR1A: PUSHJ P,SCAN ;GET THE DIMENSION.
TLNN A,NUMFLG ;MAKE SURE IT'S A NUMBER.
ERROR <Dimension should be a number>
COMMENT ⊗ Dynamic arrays are not implimented. ⊗;
MOVE B,(A) ;GET VALUE.
TLNN A,FIXFLG ;IS IT FLOATING ?
IFE KI10SW,< KAFIX B,233000 >
IFN KI10SW,< KIFIX B,B >
DARR3: POP P,T ;PTR. TO NAME IN TABLE...
JUMPE T,DARR2 ;UNLESS ITS THE MARK.
JUMPG T,DARR4 ;WAS IT PREVIOUSLY DEFINED ?
HRRZ T1,(T) ;YES. GET ITS BASE ADDRESS.
JUMPE T1,DARR4 ;IN CASE WE GOT INTERRUPTED
CAMG B,-1(T1) ;IS NEW DIMENSION > OLD ?
JRST DARR3 ;NO. LEAVE OLD DEFINITION ALONE.
DARR4: PUSH P,T ;SAVE NAME
MOVEI T,3(B) ;DIMENSION+2
PUSHJ P,GPS ;GET SOME CORE
MOVEI A,3(T) ;(FOR COMPATABLITY)
POP P,T ;RECOVER NAME
HRRM A,(T) ;PUT IN SYM. TABLE.
MOVEM B,-1(A) ;PUT DIMENSION IN -1TH ELEMENT.
HRLI A,INSXR ;PUT GOOD INDEX FIELD IN A...
MOVEM A,-2(A) ;PUT PTR. TO ARRAY WITH INDEX IN AR[-2]
MOVEM T,-3(A) ;PUT PTR. TO SYM. TABLE ENTRY FOR DEBUGGING IN AR[-3]
MOVE A,T ;FOR PRNTSYM
PUSHJ P,DCLMSG ;PRINT MESSAGE
JUMP [ASCIZ/ARRAY - /]
JRST DARR3 ;TRY FOR ANOTHER.
DARR2: PUSHJ P,SCAN ;GET THE ).
CAMN A,COMMAV ;IS IT AN COMMA?
ERROR <Multiply dimensional array not implimented, sorry>
CAMN A,RPARV ;Can be ')'
JRST DARR2A
CAME A,RGTBRK ;Or ']'
WARN <Missing ')' in array declaration>
DARR2A: PUSHJ P,SCAN
CAMN A,COMMAV ;A COMMA ?
JRST DARR ;YES. START OVER AGAIN.
POPJ P,
SUBTTL The Loader
;; THE WONDERFUL, WINNING LOADER.
BEGIN LOADER
R←1
I←2
V←3
VW←A
XY←B
LOC←C
TYPE←H
COMMENT ⊗ RELOCATION BYTE FORMAT
_______________
| | | | |
| V | W | X | Y |
|___|___|___|___|
VW=0 XY=0 UNRELOCATED DATA
XY≠0 ENDMARK IF DATA=0 ELSE FIXUP
VW≠0 XY=0 RESET LOC. COUNTER (NOT IMPLEMENTED, ERROR CONDITION)
VW=01 R-TIME RELOCATION
VW=10 I-TIME RELOCATION
VW=11 VARIABLE AREA RELOCATION
X=0 RELOCATE LEFT HALF
Y=0 RELOCATE RIGHT HALF
⊗;
↑LOADER:
HRRZ T,RLOC ;SEE HOW MUCH CORE WE NEED
ADD T,ILOC
ADD T,VLOC
HRRZ T,T ;(Note: could be requesting zero words. Probably
; should do something about that like return
; quickly)
PUSHJ P,GPS ;GET IT
MOVEM T,LSTLOA ;FOR DEBUGGING!
COMMENT ⊗ WOW, HOW DID THIS HAPPEN, I-TIME CODE MUST BE LOADED BEFORE
;R-TIME CODE!!!
MOVE R,T
; MOVE R,JOBFF ;R-TIME CODE RELOCATION CONST. *****
HRRZ I,RLOC
ADD I,R ;I-TIME CONST.
HRRZ V,ILOC
ADD V,I ;VARIABLE RELOC. CONST.
⊗;
MOVE I,T
HRRZ R,ILOC
ADD R,I ;I-TIME CONST.
HRRZ V,RLOC
ADD V,R ;VARIABLE RELOC. CONST.
MOVE T3,V
ADD T3,VLOC ;PROGRAM BREAK.
HRRZ A,T3
HRL A,I ;WE START WITH I-TIME CODE NOW!
HRRI A,1(I)
SETZM (I)
BLT A,-1(T3)
MOVEI TYPE,0 ;START WITH R-TIME CODE.
NXTCHN:
ADDI TYPE,1 ;GO TO NEXT CHAIN OF BUFFERS.
CAILE TYPE,3 ;ALL DONE ?
; POPJ P, ;YES.
JRST [ DEBUG2(LOADED) ;A HANDY BREAKPNT FOR MODE 4
POP OSP,BEGFRE ;RELEASE FREE STORAGE USED IN
MOVE 1,LSTLOA ;RETURN ADDRESS IN 1
POPJ P,] ;COMPILATION (SEE ENDP1)
PUSH P,[NEXT1] ;FAKE UP A RETURN TO LDL1.
MOVE LOC,(TYPE) ;INIT. THE CURRENT LOC. COUNTER.
SKIPA F,FCBUF-1(TYPE) ;PTR. TO FIRST BUF. OF CHAIN.
NXTBUF:
HRRZ F,(F) ;PTR. TO NEXT BUF. OF CHAIN.
HRRZ E,F ;SET UP BYTE PTR. TO RELOC. BITS.
HRLI E,200
HRRZI D,LOBUFS/12+2(F) ;PTR. TO DATA IN BUF.
HRLI D,-<LOBUFS-LOBUFS/12-2> ;WORD COUNT.
GETWRD: AOBJP D,NXTBUF ;WORD COUNT EXHAUSTED ?
MOVE (D) ;NO. PICK UP NEXT DATA WORD.
ILDB VW,E ;FIRST 2 REL. BITS.
ILDB XY,E ;LAST 2.
POPJ P,
NEXT: PUSHJ P,GETWRD ;GET NEXT WORD FROM BUFFER.
NEXT1: JUMPE VW,FIXUP ;VW=0, NO REL. GIVEN; MAY BE A FIXUP.
JUMPE XY,RESETP ;XY=0, IF NEITHER HALF, THEN IT'S A RESET.
PUSH P,CPUTWRD ;ANOTHER FAKE RETURN ADDRESS.
RELOCATE: TRNE XY,1 ;RELOCATE RIGHT HALF ?
ADD (VW) ;YES.
TRNN XY,2 ;LEFT HALF ?
POPJ P, ;NO.
MOVSS (VW)
ADD (VW)
MOVSS (VW)
POPJ P,
PUTWRD: ADDM (LOC) ;PUT IN CORE.
CNEXT: AOJA LOC,NEXT ;GET ANOTHER.
; More Loader (But not much more, you will notice!).
COMMENT ⊗ FIXUPS
VW=0; XY≠0; DATA≠0
FIXUP DATA WORD:
_ ___ _ _____________ _ _ ___ _________________________________
| | | | | | | | | | |
|B|L|R|S|C| |V|W| | POINTER TO ADDRESS TO FIXUP |
|_|_|_|_|_|___________|_|_|___|_________________________________|
0 1 2 3 4 14 15 18
VW RELOCATE THE ADDRESS AS IN DATA WORDS
B=0 (NXTWRD) LOC. COUNTER IS THE FIXUP DATA
B=1 THE FOLLOWING WORD IN THE BUFFER
L=1 (RLFXBT) RELOCATE LEFT HALF
R=1 (RRFXBT) RELOCATE RIGHT HALF
S=1 (SWAPBT) THE HALF-WORDS ARE EXCHANGED.
C=1 (CHAINBT) CHAIN FIXUP (IF ADDRESS PART OF WORD POINTED TO
IS NON-ZERO, THEN PREFORM CHAIN FIXUP OF THAT ONE
TOO, REPEATING UNTIL ADDRESS PART IS ZERO)
⊗;
FIXUP:
CPUTWRD:JUMPE XY,PUTWRD ;XY=0, PERHAPS NOT A FIXUP.
JUMPE NXTCHN ;VW=0, XY≠0, IT MIGHT EVEN BE AN END MARK.
LDB T3,[POINT 2,0,15] ;A FIXUP. GET REL. BITS FOR PTR.
DPB T3,[POINT 5,0,17]
PUSH P,0
JUMPG USEPC ;IS VALUE OF FIXUP TO BE FOUND IN BUFFER ?
PUSHJ P,GETWRD ;YES. GET IT.
PUSHJ P,RELOCATE ;PERFORM ANY INDICATED RELOCATION ON IT.
SKIPA T3,0 ;MOVE RELOCATED VALUE INTO T3.
USEPC: MOVE T3,LOC ;VALUE IS CURRENT LOCATION.
POP P,0 ;BRING BACK THE POINTER WORD.
TLNE CHAINBT ;IS THIS A CHAIN FIXUP?
JRST FXCHAIN ;YES
TLNE SWAPBT ;SHOULD WE EXCHANGE HALVES OF THE VALUE ?
MOVSS T3 ;YES.
TLNE RRFXBT ;SHOULD WE REPLACE THE RIGHT HALF OF THE LOCATION ?
HRRM T3,@0 ;YES. SEE THE POINTER RELOCATION HAPPEN AUTOMATICALLY !!
TLNE LRFXBT ;REPLACE THE LEFT HALF ?
HLLM T3,@0 ;YES.
TLNN LRFXBT+RRFXBT ;IF NEITHER HALF REPLACED, THEN
ADDM T3,@0 ;IT'S AN ADDITIVE FIXUP.
JRST NEXT ;BACK TO MAIN LOOP.
FXCHA2: HRRZ 0,XY ;GET ADDRESS FOR NEXT FIXUP
JUMPE NEXT ;BACK TO MAIN LOOP
FXCHAIN: HRRZ XY,@0 ;SAVE NEXT PART OF CHAIN
HRRM T3,@0 ;DO FIXUP
JRST FXCHA2 ;DO NEXT OF CHAIN
RESETP: LDB T3,[POINT 2,0,19]
CAMN T3,TYPE ;BETTER AGREE WITH CURRENT RELOCATION
TLNN 1 ;AND IT BETTER LOOK LIKE IT TOO
PUSHJ P,DRYROT ;IS NOT! SOMETHING IS VERY WRONG!!!!
PUSHJ P,RELOCATE
MOVE LOC,0 ;SET IT
JRST NEXT
BEND LOADER
DRYROT:
ERROR (C O M P I L E R E R R O R ! ! !
Get TOVAR or save this core image and A COPY OF THE INPUT FILE and leave a
message by saying MAIL TVR!!!)
COMMENT ⊗ Something unexpected has happened which would probably should be
looked at as it is most likely a bug. ⊗;